fix: README -> README.md

ta6ob/c/Makefile

@@ -0,0 +1,47 @@
+# Mf-ta6ob
+# Copyright 1984-2017 Cisco Systems, Inc.
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ta6ob
+Cpu = X86_64
+
+mdinclude = -I/usr/local/include -I/usr/X11R6/include
+mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid
+C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O2 -D_REENTRANT -pthread ${CFLAGS}
+o = o
+mdsrc = i3le.c
+mdobj = i3le.o
+
+.SUFFIXES:
+.SUFFIXES: .c .o
+
+.c.o:
+	$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c
+
+include Mf-base
+
+${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
+	${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
+
+${KernelLib}: ${kernelobj}
+	${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
+
+${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
+	$C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
+
+../zlib/configure.log:
+	(cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64)
+
+../lz4/lib/liblz4.a: ${LZ4Sources}
+	(cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a)

ta6ob/c/Mf-base

@@ -0,0 +1,82 @@
+# Mf-base
+# Copyright 1984-2017 Cisco Systems, Inc.
+# 
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+# 
+# http://www.apache.org/licenses/LICENSE-2.0
+# 
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+include Mf-config
+export CC CFLAGS LD LDFLAGS
+
+Include=../boot/$m
+PetiteBoot=../boot/$m/petite.boot
+SchemeBoot=../boot/$m/scheme.boot
+Main=../boot/$m/main.$o
+Scheme=../bin/$m/scheme
+
+# One of these sets is referenced in Mf-config to select between
+# linking with kernel.o or libkernel.a
+
+KernelO=../boot/$m/kernel.$o
+KernelOLinkDeps=
+KernelOLinkLibs=
+
+KernelLib=../boot/$m/libkernel.a
+KernelLibLinkDeps=${zlibDep} ${LZ4Dep}
+KernelLibLinkLibs=${zlibLib} ${LZ4Lib}
+
+kernelsrc=statics.c segment.c alloc.c symbol.c intern.c gcwrapper.c gc-011.c gc-ocd.c gc-oce.c\
+ number.c schsig.c io.c new-io.c print.c fasl.c stats.c foreign.c prim.c prim5.c flushcache.c\
+ schlib.c thread.c expeditor.c scheme.c compress-io.c
+
+kernelobj=${kernelsrc:%.c=%.$o} ${mdobj}
+
+kernelhdr=system.h types.h version.h globals.h externs.h segment.h gc.c sort.h thread.h config.h compress-io.h itest.c nocurses.h
+
+mainsrc=main.c
+
+mainobj:=${mainsrc:%.c=%.$o}
+
+doit: ${Scheme}
+
+source: ${kernelsrc} ${kernelhdr} ${mdsrc} ${mainsrc}
+
+${Main}: ${mainobj}
+	cp -p ${mainobj} ${Main}
+
+rootsrc=$(shell cd ../../c; echo *)
+${rootsrc}:
+ifeq ($(OS),Windows_NT)
+	cp -p ../../c/$@ $@
+else
+	ln -s ../../c/$@ $@
+endif
+
+scheme.o: itest.c
+scheme.o main.o: config.h
+${kernelobj}: system.h types.h version.h externs.h globals.h segment.h thread.h sort.h compress-io.h nocurses.h
+${kernelobj}: ${Include}/equates.h ${Include}/scheme.h
+${mainobj}: ${Include}/scheme.h
+${kernelobj}: ${zlibHeaderDep} ${LZ4HeaderDep}
+gc-011.o gc-ocd.o gc-oce.o: gc.c
+
+../zlib/zlib.h ../zlib/zconf.h: ../zlib/configure.log
+
+../zlib/libz.a: ../zlib/configure.log
+	(cd ../zlib; ${MAKE})
+
+LZ4Sources=../lz4/lib/lz4.h ../lz4/lib/lz4frame.h \
+           ../lz4/lib/lz4.c ../lz4/lib/lz4frame.c \
+           ../lz4/lib/lz4hc.c ../lz4/lib/xxhash.c
+
+clean:
+	rm -f *.$o ${mdclean}
+	rm -f Make.out

ta6ob/c/Mf-config

@@ -0,0 +1,22 @@
+CC=gcc
+CPPFLAGS=
+CFLAGS=
+LD=ld
+LDFLAGS=
+AR=ar
+ARFLAGS=rc
+RANLIB=ranlib
+WINDRES=windres
+cursesLib=-lcurses
+ncursesLib=-lncurses
+zlibInc=-I../zlib
+LZ4Inc=-I../lz4/lib
+zlibDep=../zlib/libz.a
+LZ4Dep=../lz4/lib/liblz4.a
+zlibLib=../zlib/libz.a
+LZ4Lib=../lz4/lib/liblz4.a
+zlibHeaderDep=../zlib/zconf.h ../zlib/zlib.h
+LZ4HeaderDep=../lz4/lib/lz4.h ../lz4/lib/lz4frame.h
+Kernel=${KernelO}
+KernelLinkDeps=${KernelOLinkDeps}
+KernelLinkLibs=${KernelOLinkLibs}

ta6ob/c/Mf-ta6ob

@@ -0,0 +1,47 @@
+# Mf-ta6ob
+# Copyright 1984-2017 Cisco Systems, Inc.
+#
+# Licensed under the Apache License, Version 2.0 (the "License");
+# you may not use this file except in compliance with the License.
+# You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing, software
+# distributed under the License is distributed on an "AS IS" BASIS,
+# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+# See the License for the specific language governing permissions and
+# limitations under the License.
+
+m = ta6ob
+Cpu = X86_64
+
+mdinclude = -I/usr/local/include -I/usr/X11R6/include
+mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid
+C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O2 -D_REENTRANT -pthread ${CFLAGS}
+o = o
+mdsrc = i3le.c
+mdobj = i3le.o
+
+.SUFFIXES:
+.SUFFIXES: .c .o
+
+.c.o:
+	$C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c
+
+include Mf-base
+
+${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep}
+	${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib}
+
+${KernelLib}: ${kernelobj}
+	${AR} ${ARFLAGS} ${KernelLib} ${kernelobj}
+
+${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main}
+	$C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS}
+
+../zlib/configure.log:
+	(cd ../zlib; CFLAGS="${CFLAGS} -m64" ./configure --64)
+
+../lz4/lib/liblz4.a: ${LZ4Sources}
+	(cd ../lz4/lib; CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a)

ta6ob/c/alloc.c

@@ -0,0 +1,862 @@
+/* alloc.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+/* locally defined functions */
+static void maybe_fire_collector(void);
+
+void S_alloc_init(void) {
+    ISPC s; IGEN g; UINT i;
+
+    if (S_boot_time) {
+      /* reset the allocation tables */
+        for (g = 0; g <= static_generation; g++) {
+            S_G.bytes_of_generation[g] = 0;
+            for (s = 0; s <= max_real_space; s++) {
+                S_G.base_loc[g][s] = FIX(0);
+                S_G.first_loc[g][s] = FIX(0);
+                S_G.next_loc[g][s] = FIX(0);
+                S_G.bytes_left[g][s] = 0;
+                S_G.bytes_of_space[g][s] = 0;
+            }
+        }
+
+        /* initialize the dirty-segment lists. */
+        for (i = 0; i < DIRTY_SEGMENT_LISTS; i += 1) {
+          S_G.dirty_segments[i] = NULL;
+        }
+
+        S_G.collect_trip_bytes = default_collect_trip_bytes;
+        S_G.g0_bytes_after_last_gc = 0;
+
+       /* set to final value in prim.c when known */
+        S_protect(&S_G.nonprocedure_code);
+        S_G.nonprocedure_code = FIX(0);
+
+        S_protect(&S_G.null_vector);
+        find_room(space_new, 0, type_typed_object, size_vector(0), S_G.null_vector);
+        VECTTYPE(S_G.null_vector) = (0 << vector_length_offset) | type_vector;
+
+        S_protect(&S_G.null_fxvector);
+        find_room(space_new, 0, type_typed_object, size_fxvector(0), S_G.null_fxvector);
+        FXVECTOR_TYPE(S_G.null_fxvector) = (0 << fxvector_length_offset) | type_fxvector;
+
+        S_protect(&S_G.null_bytevector);
+        find_room(space_new, 0, type_typed_object, size_bytevector(0), S_G.null_bytevector);
+        BYTEVECTOR_TYPE(S_G.null_bytevector) = (0 << bytevector_length_offset) | type_bytevector;
+
+        S_protect(&S_G.null_string);
+        find_room(space_new, 0, type_typed_object, size_string(0), S_G.null_string);
+        STRTYPE(S_G.null_string) = (0 << string_length_offset) | type_string;
+    }
+}
+
+void S_protect(ptr *p) {
+    if (S_G.protect_next > max_protected)
+        S_error_abort("max_protected constant too small");
+    *p = snil;
+    S_G.protected[S_G.protect_next++] = p;
+}
+
+/* S_reset_scheme_stack is always called with mutex */
+void S_reset_scheme_stack(ptr tc, iptr n) {
+    ptr *x; iptr m;
+
+  /* we allow less than one_shot_headroom here for no truly justifiable
+     reason */
+    n = ptr_align(n + (one_shot_headroom >> 1));
+
+    x = &STACKCACHE(tc);
+    for (;;) {
+        if (*x == snil) {
+            if (n < default_stack_size) n = default_stack_size;
+          /* stacks are untyped objects */
+            find_room(space_new, 0, typemod, n, SCHEMESTACK(tc));
+            break;
+        }
+        if ((m = CACHEDSTACKSIZE(*x)) >= n) {
+            n = m;
+            SCHEMESTACK(tc) = *x;
+/* if we decide to leave KEEPSMALLPUPPIES undefined permanently, we should
+   rewrite this code to remove the indirect on x */
+/* #define KEEPSMALLPUPPIES */
+#ifdef KEEPSMALLPUPPIES
+            *x = CACHEDSTACKLINK(*x);
+#else
+            STACKCACHE(tc) = CACHEDSTACKLINK(*x);
+#endif
+            break;
+        }
+        x = &CACHEDSTACKLINK(*x);
+    }
+    SCHEMESTACKSIZE(tc) = n;
+    ESP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + n - stack_slop);
+    SFP(tc) = (ptr)SCHEMESTACK(tc);
+}
+
+ptr S_compute_bytes_allocated(ptr xg, ptr xs) {
+  ptr tc = get_thread_context();
+  ISPC s, smax, smin; IGEN g, gmax, gmin;
+  uptr n;
+
+  gmin = (IGEN)UNFIX(xg);
+  if (gmin < 0) {
+    gmin = 0;
+    gmax = static_generation;
+  } else if (gmin == S_G.new_max_nonstatic_generation) {
+   /* include virtual inhabitents too */
+    gmax = S_G.max_nonstatic_generation;
+  } else {
+    gmax = gmin;
+  }
+
+  smin = (ISPC)(UNFIX(xs));
+  smax = smin < 0 ? max_real_space : smin;
+  smin = smin < 0 ? 0 : smin;
+
+  n = 0;
+
+  g = gmin;
+  while (g <= gmax) {
+    for (s = smin; s <= smax; s++) {
+      ptr next_loc = S_G.next_loc[g][s];
+     /* add in bytes previously recorded */
+      n += S_G.bytes_of_space[g][s];
+     /* add in bytes in active segments */
+      if (next_loc != FIX(0))
+        n += (char *)next_loc - (char *)S_G.base_loc[g][s];
+    }
+    if (g == S_G.max_nonstatic_generation)
+      g = static_generation;
+    else
+      g += 1;
+  }
+
+ /* subtract off bytes not allocated */
+  if (gmin == 0 && smin <= space_new && space_new <= smax)
+      n -= (uptr)REAL_EAP(tc) - (uptr)AP(tc);
+
+  return Sunsigned(n);
+}
+
+static void maybe_fire_collector(void) {
+  if (S_G.bytes_of_generation[0] - S_G.g0_bytes_after_last_gc >= S_G.collect_trip_bytes)
+    S_fire_collector();
+}
+
+/* find_more_room
+ * S_find_more_room is called from the macro find_room when
+ * the current segment is too full to fit the allocation.
+ *
+ * A forward_marker followed by a pointer to
+ * the newly obtained segment is placed at next_loc to show
+ * gc where the end of this segment is and where the next
+ * segment of this type resides.  Allocation occurs from the
+ * beginning of the newly obtained segment.  The need for the
+ * eos marker explains the (2 * ptr_bytes) byte factor in
+ * S_find_more_room.
+ */
+/* S_find_more_room is always called with mutex */
+ptr S_find_more_room(ISPC s, IGEN g, iptr n, ptr old) {
+  iptr nsegs, seg;
+  ptr new;
+
+  S_pants_down += 1;
+
+  nsegs = (uptr)(n + 2 * ptr_bytes + bytes_per_segment - 1) >> segment_offset_bits;
+
+ /* block requests to minimize fragmentation and improve cache locality */
+  if (s == space_code && nsegs < 16) nsegs = 16;
+
+  seg = S_find_segments(s, g, nsegs);
+  new = build_ptr(seg, 0);
+
+  if (old == FIX(0)) {
+   /* first object of this space */
+    S_G.first_loc[g][s] = new;
+  } else {
+    uptr bytes = (char *)old - (char *)S_G.base_loc[g][s];
+   /* increment bytes_allocated by the closed-off partial segment */
+    S_G.bytes_of_space[g][s] += bytes;
+    S_G.bytes_of_generation[g] += bytes;
+   /* lay down an end-of-segment marker */
+    *(ptr*)old = forward_marker;
+    *((ptr*)old + 1) = new;
+  }
+
+ /* base address of current block of segments to track amount of allocation */
+  S_G.base_loc[g][s] = new;
+
+  S_G.next_loc[g][s] = (ptr)((uptr)new + n);
+  S_G.bytes_left[g][s] = (nsegs * bytes_per_segment - n) - 2 * ptr_bytes;
+
+  if (g == 0 && S_pants_down == 1) maybe_fire_collector();
+
+  S_pants_down -= 1;
+  return new;
+}
+
+/* S_reset_allocation_pointer is always called with mutex */
+/* We always allocate exactly one segment for the allocation area, since
+   we can get into hot water with formerly locked objects, specifically
+   symbols and impure records, that cross segment boundaries.  This allows
+   us to maintain the invariant that no object crosses a segment boundary
+   unless it starts on a segment boundary (and is thus at least one
+   segment long).  NB.  This invariant does not apply to code objects
+   since we grab large blocks of segments for them.
+*/
+
+void S_reset_allocation_pointer(ptr tc) {
+  iptr seg;
+
+  S_pants_down += 1;
+
+  seg = S_find_segments(space_new, 0, 1);
+
+  /* NB: if allocate_segments didn't already ensure we don't use the last segment
+     of memory, we'd have to reject it here so cp2-alloc can avoid a carry check for
+     small allocation requests, using something like this:
+
+     if (seg == (((uptr)1 << (ptr_bits - segment_offset_bits)) - 1))
+       seg = S_find_segments(space_new, 0, 1);
+  */
+
+  S_G.bytes_of_space[0][space_new] += bytes_per_segment;
+  S_G.bytes_of_generation[0] += bytes_per_segment;
+
+  if (S_pants_down == 1) maybe_fire_collector();
+
+  AP(tc) = build_ptr(seg, 0);
+  REAL_EAP(tc) = EAP(tc) = (ptr)((uptr)AP(tc) + bytes_per_segment);
+
+  S_pants_down -= 1;
+}
+
+
+FORCEINLINE void mark_segment_dirty(seginfo *si, IGEN from_g, IGEN to_g) {
+  IGEN old_to_g = si->min_dirty_byte;
+  if (to_g < old_to_g) {
+    seginfo **pointer_to_first, *oldfirst;
+    if (old_to_g != 0xff) {
+      seginfo *next = si->dirty_next, **prev = si->dirty_prev;
+      /* presently on some other list, so remove */
+      *prev = next;
+      if (next != NULL) next->dirty_prev = prev;
+    }
+    oldfirst = *(pointer_to_first = &DirtySegments(from_g, to_g));
+    *pointer_to_first = si;
+    si->dirty_prev = pointer_to_first;
+    si->dirty_next = oldfirst;
+    if (oldfirst != NULL) oldfirst->dirty_prev = &si->dirty_next;
+    si->min_dirty_byte = to_g;
+  }
+}
+
+void S_dirty_set(ptr *loc, ptr x) {
+  *loc = x;
+  if (!Sfixnump(x)) {
+    seginfo *si = SegInfo(addr_get_segment(loc));
+    IGEN from_g = si->generation;
+    if (from_g != 0) {
+      si->dirty_bytes[((uptr)loc >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0;
+      mark_segment_dirty(si, from_g, 0);
+    }
+  }
+}
+
+void S_mark_card_dirty(uptr card, IGEN to_g) {
+  uptr loc = card << card_offset_bits;
+  uptr seg = addr_get_segment(loc);
+  seginfo *si = SegInfo(seg);
+  uptr cardno = card & ((1 << segment_card_offset_bits) - 1);
+  if (to_g < si->dirty_bytes[cardno]) {
+    si->dirty_bytes[cardno] = to_g;
+    mark_segment_dirty(si, si->generation, to_g);
+  }
+}
+
+/* scan remembered set from P to ENDP, transferring to dirty vector */
+void S_scan_dirty(ptr **p, ptr **endp) {
+  uptr this, last;
+ 
+  last = 0;
+
+  while (p < endp) {
+    ptr *loc = *p;
+   /* whether building s directory or running UXLB code, the most
+      common situations are that *loc is a fixnum, this == last, or loc
+      is in generation 0. the generated code no longer adds elements
+      to the remembered set if the RHS val is a fixnum.  the other
+      checks we do here.  we don't bother looking for *loc being an
+      immediate or outside the heap, nor for the generation of *loc
+      being the same or older than the generation of loc, since these
+      don't seem to weed out many dirty writes, and we don't want to
+      waste time here on fruitless memory reads and comparisions */
+    if ((this = (uptr)loc >> card_offset_bits) != last) {
+      seginfo *si = SegInfo(addr_get_segment(loc));
+      IGEN from_g = si->generation;
+      if (from_g != 0) {
+        si->dirty_bytes[((uptr)loc >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0;
+        if (this >> segment_card_offset_bits != last >> segment_card_offset_bits) mark_segment_dirty(si, from_g, 0);
+      }
+      last = this;
+    }
+    p += 1;
+  }
+}
+
+/* S_scan_remembered_set is called from generated machine code when there
+ * is insufficient room for a remembered set addition.
+ */
+
+void S_scan_remembered_set(void) {
+  ptr tc = get_thread_context();
+  uptr ap, eap, real_eap;
+
+  tc_mutex_acquire()
+
+  ap = (uptr)AP(tc);
+  eap = (uptr)EAP(tc);
+  real_eap = (uptr)REAL_EAP(tc);
+
+  S_scan_dirty((ptr **)eap, (ptr **)real_eap);
+  eap = real_eap;
+
+  if (eap - ap > alloc_waste_maximum) {
+    AP(tc) = (ptr)ap;
+    EAP(tc) = (ptr)eap;
+  } else {
+    uptr bytes = eap - ap;
+    S_G.bytes_of_space[0][space_new] -= bytes;
+    S_G.bytes_of_generation[0] -= bytes;
+    S_reset_allocation_pointer(tc);
+  }
+
+  tc_mutex_release()
+}
+
+/* S_get_more_room is called from generated machine code when there is
+ * insufficient room for an allocation.  ap has already been incremented
+ * by the size of the object and xp is a (typed) pointer to the value of
+ * ap before the allocation attempt.  xp must be set to a new object of
+ * the appropriate type and size.
+ */
+
+void S_get_more_room(void) {
+  ptr tc = get_thread_context();
+  ptr xp; uptr ap, type, size;
+
+  xp = XP(tc);
+  if ((type = TYPEBITS(xp)) == 0) type = typemod;
+  ap = (uptr)UNTYPE(xp, type);
+  size = (uptr)((iptr)AP(tc) - (iptr)ap);
+
+  XP(tc) = S_get_more_room_help(tc, ap, type, size);
+}
+
+ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) {
+  ptr x; uptr eap, real_eap;
+
+  eap = (uptr)EAP(tc);
+  real_eap = (uptr)REAL_EAP(tc);
+
+  tc_mutex_acquire()
+
+  S_scan_dirty((ptr **)eap, (ptr **)real_eap);
+  eap = real_eap;
+
+  if (eap - ap >= size) {
+    x = TYPE(ap, type);
+    ap += size;
+    if (eap - ap > alloc_waste_maximum) {
+      AP(tc) = (ptr)ap;
+      EAP(tc) = (ptr)eap;
+    } else {
+      uptr bytes = eap - ap;
+      S_G.bytes_of_space[0][space_new] -= bytes;
+      S_G.bytes_of_generation[0] -= bytes;
+      S_reset_allocation_pointer(tc);
+    }
+  } else if (eap - ap > alloc_waste_maximum) {
+    AP(tc) = (ptr)ap;
+    EAP(tc) = (ptr)eap;
+    find_room(space_new, 0, type, size, x);
+  } else {
+    uptr bytes = eap - ap;
+    S_G.bytes_of_space[0][space_new] -= bytes;
+    S_G.bytes_of_generation[0] -= bytes;
+    S_reset_allocation_pointer(tc);
+    ap = (uptr)AP(tc);
+    if (size + alloc_waste_maximum <= (uptr)EAP(tc) - ap) {
+      x = TYPE(ap, type);
+      AP(tc) = (ptr)(ap + size);
+    } else {
+      find_room(space_new, 0, type, size, x);
+    }
+  }
+
+  tc_mutex_release()
+
+  return x;
+}
+
+/* S_cons_in is always called with mutex */
+ptr S_cons_in(ISPC s, IGEN g, ptr car, ptr cdr) {
+    ptr p;
+
+    find_room(s, g, type_pair, size_pair, p);
+    INITCAR(p) = car;
+    INITCDR(p) = cdr;
+    return p;
+}
+
+ptr Scons(ptr car, ptr cdr) {
+    ptr tc = get_thread_context();
+    ptr p;
+
+    thread_find_room(tc, type_pair, size_pair, p);
+    INITCAR(p) = car;
+    INITCDR(p) = cdr;
+    return p;
+}
+
+ptr Sbox(ptr ref) {
+    ptr tc = get_thread_context();
+    ptr p;
+
+    thread_find_room(tc, type_typed_object, size_box, p);
+    BOXTYPE(p) = type_box;
+    INITBOXREF(p) = ref;
+    return p;
+}
+
+ptr S_symbol(ptr name) {
+    ptr tc = get_thread_context();
+    ptr p;
+
+    thread_find_room(tc, type_symbol, size_symbol, p);
+  /* changes here should be reflected in the oblist collection code in gc.c */
+    INITSYMVAL(p) = sunbound;
+    INITSYMCODE(p,S_G.nonprocedure_code);
+    INITSYMPLIST(p) = snil;
+    INITSYMSPLIST(p) = snil;
+    INITSYMNAME(p) = name;
+    INITSYMHASH(p) = Sfalse;
+    return p;
+}
+
+ptr S_rational(ptr n, ptr d) {
+    if (d == FIX(1)) return n;
+    else {
+        ptr tc = get_thread_context();
+        ptr p;
+
+        thread_find_room(tc, type_typed_object, size_ratnum, p);
+        RATTYPE(p) = type_ratnum;
+        RATNUM(p) = n;
+        RATDEN(p) = d;
+        return p;
+    }
+}
+
+ptr S_tlc(ptr keyval, ptr ht, ptr next) {
+    ptr tc = get_thread_context();
+    ptr p;
+
+    thread_find_room(tc, type_typed_object, size_tlc, p);
+    TLCTYPE(p) = type_tlc;
+    INITTLCKEYVAL(p) = keyval;
+    INITTLCHT(p) = ht;
+    INITTLCNEXT(p) = next;
+    return p;
+}
+
+/* S_vector_in is always called with mutex */
+ptr S_vector_in(ISPC s, IGEN g, iptr n) {
+    ptr p; iptr d;
+
+    if (n == 0) return S_G.null_vector;
+
+    if ((uptr)n >= maximum_vector_length)
+        S_error("", "invalid vector size request");
+
+    d = size_vector(n);
+   /* S_vector_in always called with mutex */
+    find_room(s, g, type_typed_object, d, p);
+    VECTTYPE(p) = (n << vector_length_offset) | type_vector;
+    return p;
+}
+
+ptr S_vector(iptr n) {
+    ptr tc;
+    ptr p; iptr d;
+
+    if (n == 0) return S_G.null_vector;
+
+    if ((uptr)n >= maximum_vector_length)
+        S_error("", "invalid vector size request");
+
+    tc = get_thread_context();
+
+    d = size_vector(n);
+    thread_find_room(tc, type_typed_object, d, p);
+    VECTTYPE(p) = (n << vector_length_offset) | type_vector;
+    return p;
+}
+
+ptr S_fxvector(iptr n) {
+    ptr tc;
+    ptr p; iptr d;
+
+    if (n == 0) return S_G.null_fxvector;
+
+    if ((uptr)n > (uptr)maximum_fxvector_length)
+        S_error("", "invalid fxvector size request");
+
+    tc = get_thread_context();
+
+    d = size_fxvector(n);
+    thread_find_room(tc, type_typed_object, d, p);
+    FXVECTOR_TYPE(p) = (n << fxvector_length_offset) | type_fxvector;
+    return p;
+}
+
+ptr S_bytevector(iptr n) {
+    ptr tc;
+    ptr p; iptr d;
+
+    if (n == 0) return S_G.null_bytevector;
+
+    if ((uptr)n > (uptr)maximum_bytevector_length)
+        S_error("", "invalid bytevector size request");
+
+    tc = get_thread_context();
+
+    d = size_bytevector(n);
+    thread_find_room(tc, type_typed_object, d, p);
+    BYTEVECTOR_TYPE(p) = (n << bytevector_length_offset) | type_bytevector;
+    return p;
+}
+
+ptr S_null_immutable_vector(void) {
+  ptr v;
+  find_room(space_new, 0, type_typed_object, size_vector(0), v);
+  VECTTYPE(v) = (0 << vector_length_offset) | type_vector | vector_immutable_flag;
+  return v;
+}
+
+ptr S_null_immutable_fxvector(void) {
+  ptr v;
+  find_room(space_new, 0, type_typed_object, size_fxvector(0), v);
+  VECTTYPE(v) = (0 << fxvector_length_offset) | type_fxvector | fxvector_immutable_flag;
+  return v;
+}
+
+ptr S_null_immutable_bytevector(void) {
+  ptr v;
+  find_room(space_new, 0, type_typed_object, size_bytevector(0), v);
+  VECTTYPE(v) = (0 << bytevector_length_offset) | type_bytevector | bytevector_immutable_flag;
+  return v;
+}
+
+ptr S_null_immutable_string(void) {
+  ptr v;
+  find_room(space_new, 0, type_typed_object, size_string(0), v);
+  VECTTYPE(v) = (0 << string_length_offset) | type_string | string_immutable_flag;
+  return v;
+}
+
+ptr S_record(iptr n) {
+    ptr tc = get_thread_context();
+    ptr p;
+
+    thread_find_room(tc, type_typed_object, n, p);
+    return p;
+}
+
+ptr S_closure(ptr cod, iptr n) {
+    ptr tc = get_thread_context();
+    ptr p; iptr d;
+
+    d = size_closure(n);
+    thread_find_room(tc, type_closure, d, p);
+    CLOSENTRY(p) = cod;
+    return p;
+}
+
+/* S_mkcontinuation is always called with mutex */
+ptr S_mkcontinuation(ISPC s, IGEN g, ptr nuate, ptr stack, iptr length, iptr clength,
+     ptr link, ptr ret, ptr winders) {
+    ptr p;
+
+    find_room(s, g, type_closure, size_continuation, p);
+    CLOSENTRY(p) = nuate;
+    CONTSTACK(p) = stack;
+    CONTLENGTH(p) = length;
+    CONTCLENGTH(p) = clength;
+    CONTLINK(p) = link;
+    CONTRET(p) = ret;
+    CONTWINDERS(p) = winders;
+    return p;
+}
+
+ptr Sflonum(double x) {
+    ptr tc = get_thread_context();
+    ptr p;
+
+    thread_find_room(tc, type_flonum, size_flonum, p);
+    FLODAT(p) = x;
+    return p;
+}
+
+ptr S_inexactnum(double rp, double ip) {
+    ptr tc = get_thread_context();
+    ptr p;
+
+    thread_find_room(tc, type_typed_object, size_inexactnum, p);
+    INEXACTNUM_TYPE(p) = type_inexactnum;
+    INEXACTNUM_REAL_PART(p) = rp;
+    INEXACTNUM_IMAG_PART(p) = ip;
+    return p;
+}
+
+/* S_thread is always called with mutex */
+ptr S_thread(ptr xtc) {
+    ptr p;
+
+   /* don't use thread_find_room since we may be building the current thread */
+    find_room(space_new, 0, type_typed_object, size_thread, p);
+    TYPEFIELD(p) = (ptr)type_thread;
+    THREADTC(p) = (uptr)xtc;
+    return p;
+}
+
+ptr S_exactnum(ptr a, ptr b) {
+    ptr tc = get_thread_context();
+    ptr p;
+
+    thread_find_room(tc, type_typed_object, size_exactnum, p);
+    EXACTNUM_TYPE(p) = type_exactnum;
+    EXACTNUM_REAL_PART(p) = a;
+    EXACTNUM_IMAG_PART(p) = b;
+    return p;
+}
+
+/* S_string returns a new string of length n.  If s is not NULL, it is
+ * copied into the new string.  If n < 0, then s must be non-NULL,
+ * and the length of s (by strlen) determines the length of the string */
+ptr S_string(const char *s, iptr n) {
+    ptr tc;
+    ptr p; iptr d;
+    iptr i;
+
+    if (n < 0) n = strlen(s);
+
+    if (n == 0) return S_G.null_string;
+
+    if ((uptr)n > (uptr)maximum_string_length)
+        S_error("", "invalid string size request");
+
+    tc = get_thread_context();
+
+    d = size_string(n);
+    thread_find_room(tc, type_typed_object, d, p);
+    STRTYPE(p) = (n << string_length_offset) | type_string;
+
+  /* fill the string with valid characters */
+    i = 0;
+
+  /* first copy input string, if any */
+    if (s != (char *)NULL) {
+      while (i != n && *s != 0) {
+        Sstring_set(p, i, *s++);
+        i += 1;
+      }
+    }
+
+  /* fill remaining slots with nul */
+    while (i != n) {
+      Sstring_set(p, i, 0);
+      i += 1;
+    }
+
+    return p;
+}
+
+ptr Sstring_utf8(const char *s, iptr n) {
+  const char* u8;
+  iptr cc, d, i, n8;
+  ptr p, tc;
+
+  if (n < 0) n = strlen(s);
+
+  if (n == 0) return S_G.null_string;
+
+  /* determine code point count cc */
+  u8 = s;
+  n8 = n;
+  cc = 0;
+  while (n8 > 0) {
+    unsigned char b1 = *(const unsigned char*)u8++;
+    n8--;
+    cc++;
+    if ((b1 & 0x80) == 0)
+      ;
+    else if ((b1 & 0x40) == 0)
+      ;
+    else if ((b1 & 0x20) == 0) {
+      if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+        u8++;
+        n8--;
+      }
+    } else if ((b1 & 0x10) == 0) {
+      if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+        u8++;
+        n8--;
+        if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+          u8++;
+          n8--;
+        }
+      }
+    } else if ((b1 & 0x08) == 0) {
+      if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+        u8++;
+        n8--;
+        if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+          u8++;
+          n8--;
+          if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+            u8++;
+            n8--;
+          }
+        }
+      }
+    }
+  }
+
+  if ((uptr)cc > (uptr)maximum_string_length)
+    S_error("", "invalid string size request");
+
+  tc = get_thread_context();
+  d = size_string(cc);
+  thread_find_room(tc, type_typed_object, d, p);
+  STRTYPE(p) = (cc << string_length_offset) | type_string;
+
+  /* fill the string */
+  u8 = s;
+  n8 = n;
+  i = 0;
+  while (n8 > 0) {
+    unsigned char b1 = *u8++;
+    int c = 0xfffd;
+    n8--;
+    if ((b1 & 0x80) == 0)
+      c = b1;
+    else if ((b1 & 0x40) == 0)
+      ;
+    else if ((b1 & 0x20) == 0) {
+      unsigned char b2;
+      if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) {
+        int x = ((b1 & 0x1f) << 6) | (b2 & 0x3f);
+        u8++;
+        n8--;
+        if (x >= 0x80)
+          c = x;
+      }
+    } else if ((b1 & 0x10) == 0) {
+      unsigned char b2;
+      if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) {
+        unsigned char b3;
+        u8++;
+        n8--;
+        if ((n8 >= 1) && (((b3 = *u8) & 0xc0) == 0x80)) {
+          int x = ((b1 & 0x0f) << 12) | ((b2 & 0x3f) << 6) | (b3 & 0x3f);
+          u8++;
+          n8--;
+          if ((x >= 0x800) && ((x < 0xd800) || (x > 0xdfff)))
+            c = x;
+        }
+      }
+    } else if ((b1 & 0x08) == 0) {
+      unsigned char b2;
+      if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) {
+        unsigned char b3;
+        u8++;
+        n8--;
+        if ((n8 >= 1) && (((b3 = *u8) & 0xc0) == 0x80)) {
+          unsigned char b4;
+          u8++;
+          n8--;
+          if ((n8 >= 1) && (((b4 = *u8) & 0xc0) == 0x80)) {
+            int x = ((b1 & 0x07) << 18) | ((b2 & 0x3f) << 12) | ((b3 & 0x3f) << 6) | (b4 & 0x3f);
+            u8++;
+            n8--;
+            if ((x >= 0x10000) && (x <= 0x10ffff))
+              c = x;
+          }
+        }
+      }
+    }
+    Sstring_set(p, i++, c);
+  }
+  return p;
+}
+
+ptr S_bignum(ptr tc, iptr n, IBOOL sign) {
+    ptr p; iptr d;
+
+    if ((uptr)n > (uptr)maximum_bignum_length)
+        S_error("", "invalid bignum size request");
+
+    d = size_bignum(n);
+    thread_find_room(tc, type_typed_object, d, p);
+    BIGTYPE(p) = (uptr)n << bignum_length_offset | sign << bignum_sign_offset | type_bignum;
+    return p;
+}
+
+/* S_code is always called with mutex */
+ptr S_code(ptr tc, iptr type, iptr n) {
+    ptr p; iptr d;
+
+    d = size_code(n);
+    find_room(space_code, 0, type_typed_object, d, p);
+    CODETYPE(p) = type;
+    CODELEN(p) = n;
+  /* we record the code modification here, even though we haven't
+     even started modifying the code yet, since we always create
+     and fill the code object within a critical section. */
+    S_record_code_mod(tc, (uptr)&CODEIT(p,0), (uptr)n);
+    return p;
+}
+
+ptr S_relocation_table(iptr n) {
+    ptr tc = get_thread_context();
+    ptr p; iptr d;
+
+    d = size_reloc_table(n);
+    thread_find_room(tc, typemod, d, p);
+    RELOCSIZE(p) = n;
+    return p;
+}
+
+ptr S_weak_cons(ptr car, ptr cdr) {
+  ptr p;
+  tc_mutex_acquire();
+  p = S_cons_in(space_weakpair, 0, car, cdr);
+  tc_mutex_release();
+  return p;
+}

ta6ob/c/compress-io.c

@@ -0,0 +1,672 @@
+/* compress-io.c
+ * Copyright 1984-2019 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+/* Dispatch to zlib or LZ4 */
+
+#include "system.h"
+#include "zlib.h"
+#include "lz4.h"
+#include "lz4frame.h"
+#include "lz4hc.h"
+#include <fcntl.h>
+#include <errno.h>
+
+#ifdef WIN32
+#include <io.h>
+# define WIN32_IZE(id) _ ## id
+# define GLZ_O_BINARY O_BINARY
+#else
+# define WIN32_IZE(id) id
+# define GLZ_O_BINARY 0
+#endif
+
+/* the value of LZ4_OUTPUT_PORT_IN_BUFFER_SIZE was determined
+   through experimentation on an intel linux server and an intel
+   osx laptop.  smaller sizes result in significantly worse compression
+   of object files, and larger sizes don't have much beneficial effect.
+   don't increase the output-port in-buffer size unless you're sure
+   it reduces object-file size or reduces compression time
+   significantly.  don't decrease it unless you're sure it doesn't
+   increase object-file size significantly.  one buffer of size
+   LZ4_OUTPUT_PORT_IN_BUFFER_SIZE is allocated per lz4-compressed
+   output port.  another buffer of a closely related size is allocated
+   per thread. */
+#define LZ4_OUTPUT_PORT_IN_BUFFER_SIZE (1 << 18)
+
+/* the values we choose for LZ4_INPUT_PORT_IN_BUFFER_SIZE and
+   LZ4_INPUT_PORT_OUT_BUFFER_SIZE don't seem to make much difference
+   in decompression speed, so we keep them fairly small.  one buffer
+   of size LZ4_INPUT_PORT_IN_BUFFER_SIZE and one buffer of size
+   LZ4_INPUT_PORT_OUT_BUFFER_SIZE are allocated per lz4-compressed
+   input port. */
+#define LZ4_INPUT_PORT_IN_BUFFER_SIZE (1 << 12)
+#define LZ4_INPUT_PORT_OUT_BUFFER_SIZE (1 << 14)
+
+typedef struct lz4File_out_r {
+  LZ4F_preferences_t preferences;
+  INT fd;
+  INT out_buffer_size;
+  INT in_pos;
+  INT err;
+  size_t stream_pos;
+  char in_buffer[LZ4_OUTPUT_PORT_IN_BUFFER_SIZE];
+} lz4File_out;
+
+typedef struct lz4File_in_r {
+  INT fd;
+  LZ4F_dctx *dctx;
+  INT in_pos, in_len, out_pos, out_len;
+  INT frame_ended;
+  INT err;
+  size_t stream_pos;
+  off_t init_pos;
+  char in_buffer[LZ4_INPUT_PORT_IN_BUFFER_SIZE];
+  char out_buffer[LZ4_INPUT_PORT_OUT_BUFFER_SIZE];
+} lz4File_in;
+
+typedef struct sized_buffer_r {
+  INT size;
+  char buffer[0];
+} sized_buffer;
+
+/* local functions */
+static glzFile glzdopen_output_gz(INT fd, INT compress_level);
+static glzFile glzdopen_output_lz4(INT fd, INT compress_level);
+static glzFile glzdopen_input_gz(INT fd);
+static glzFile glzdopen_input_lz4(INT fd, off_t init_pos);
+static INT glzread_lz4(lz4File_in *lz4, void *buffer, UINT count);
+static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count);
+static INT glzwrite_lz4(lz4File_out *lz4, void *buffer, UINT count);
+
+INT S_zlib_compress_level(INT compress_level) {
+  switch (compress_level) {
+    case COMPRESS_MIN:
+    case COMPRESS_LOW:
+      return Z_BEST_SPEED;
+    case COMPRESS_MEDIUM:
+      return (Z_BEST_SPEED + Z_BEST_COMPRESSION) / 2;
+    case COMPRESS_HIGH:
+      return (Z_BEST_SPEED + (3 * Z_BEST_COMPRESSION)) / 4;
+    case COMPRESS_MAX:
+      return Z_BEST_COMPRESSION;
+    default:
+      S_error1("S_zlib_compress_level", "unexpected compress level ~s", Sinteger(compress_level));
+      return 0;
+  }
+}
+
+static glzFile glzdopen_output_gz(INT fd, INT compress_level) {
+  gzFile gz;
+  glzFile glz;
+  INT as_append;
+  INT level;
+
+#ifdef WIN32
+  as_append = 0;
+#else
+  as_append = fcntl(fd, F_GETFL) & O_APPEND;
+#endif
+
+  if ((gz = gzdopen(fd, as_append ? "ab" : "wb")) == Z_NULL) return Z_NULL;
+
+  level = S_zlib_compress_level(compress_level);
+
+  gzsetparams(gz, level, Z_DEFAULT_STRATEGY);
+
+  if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
+    (void)gzclose(gz);
+    return Z_NULL;
+  }
+  glz->fd = fd;
+  glz->inputp = 0;
+  glz->format = COMPRESS_GZIP;
+  glz->gz = gz;
+  return glz;
+}
+
+INT S_lz4_compress_level(INT compress_level) {
+  switch (compress_level) {
+    case COMPRESS_MIN:
+    case COMPRESS_LOW:
+      return 1;
+    case COMPRESS_MEDIUM:
+      return LZ4HC_CLEVEL_MIN;
+    case COMPRESS_HIGH:
+      return (LZ4HC_CLEVEL_MIN + LZ4HC_CLEVEL_MAX) / 2;
+    case COMPRESS_MAX:
+      return LZ4HC_CLEVEL_MAX;
+    default:
+      S_error1("S_lz4_compress_level", "unexpected compress level ~s", Sinteger(compress_level));
+      return 0;
+  }
+}
+
+static glzFile glzdopen_output_lz4(INT fd, INT compress_level) {
+  glzFile glz;
+  lz4File_out *lz4;
+  INT level;
+
+  level = S_lz4_compress_level(compress_level);
+
+  if ((lz4 = malloc(sizeof(lz4File_out))) == NULL) return Z_NULL;
+  memset(&lz4->preferences, 0, sizeof(LZ4F_preferences_t));
+  lz4->preferences.compressionLevel = level;
+  lz4->fd = fd;
+  lz4->out_buffer_size = (INT)LZ4F_compressFrameBound(LZ4_OUTPUT_PORT_IN_BUFFER_SIZE, &lz4->preferences);
+  lz4->in_pos = 0;
+  lz4->err = 0;
+  lz4->stream_pos = 0;
+
+  if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
+    free(lz4);
+    return Z_NULL;
+  }
+  glz->fd = fd;
+  glz->inputp = 0;
+  glz->format = COMPRESS_LZ4;
+  glz->lz4_out = lz4;
+  return glz;
+}
+
+glzFile S_glzdopen_output(INT fd, INT compress_format, INT compress_level) {
+  switch (compress_format) {
+    case COMPRESS_GZIP:
+      return glzdopen_output_gz(fd, compress_level);
+    case COMPRESS_LZ4:
+      return glzdopen_output_lz4(fd, compress_level);
+    default:
+      S_error1("glzdopen_output", "unexpected compress format ~s", Sinteger(compress_format));
+      return Z_NULL;
+  }
+}
+
+static glzFile glzdopen_input_gz(INT fd) {
+  gzFile gz;
+  glzFile glz;
+
+  if ((gz = gzdopen(fd, "rb")) == Z_NULL) return Z_NULL;
+  
+  if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
+    (void)gzclose(gz);
+    return Z_NULL;
+  }
+  glz->fd = fd;
+  glz->inputp = 1;
+  glz->format = COMPRESS_GZIP;
+  glz->gz = gz;
+  return glz;
+}
+
+static glzFile glzdopen_input_lz4(INT fd, off_t init_pos) {
+  glzFile glz;
+  LZ4F_dctx *dctx;
+  LZ4F_errorCode_t r;
+  lz4File_in *lz4;
+
+  r = LZ4F_createDecompressionContext(&dctx, LZ4F_VERSION);
+  if (LZ4F_isError(r))
+    return Z_NULL;
+
+  if ((lz4 = malloc(sizeof(lz4File_in))) == NULL) {
+    (void)LZ4F_freeDecompressionContext(dctx);
+    return Z_NULL;
+  }
+  lz4->fd = fd;
+  lz4->dctx = dctx;
+  lz4->in_pos = 0;
+  lz4->in_len = 0;
+  lz4->out_len = 0;
+  lz4->out_pos = 0;
+  lz4->frame_ended = 0;
+  lz4->err = 0;
+  lz4->stream_pos = 0;
+  lz4->init_pos = init_pos;
+
+  if ((glz = malloc(sizeof(struct glzFile_r))) == NULL) {
+    (void)LZ4F_freeDecompressionContext(lz4->dctx);
+    free(lz4);
+    return Z_NULL;
+  }
+  glz->fd = fd;
+  glz->inputp = 1;
+  glz->format = COMPRESS_LZ4;
+  glz->lz4_in = lz4;
+  return glz;
+}
+
+glzFile S_glzdopen_input(INT fd) {
+  INT r, pos = 0;
+  unsigned char buffer[4];
+  off_t init_pos;
+
+  /* check for LZ4 magic number, otherwise defer to gzdopen */
+
+  if ((init_pos = WIN32_IZE(lseek)(fd, 0, SEEK_CUR)) == -1) return Z_NULL;
+
+  while (pos < 4) {
+    r = WIN32_IZE(read)(fd, (char*)buffer + pos, 4 - pos);
+    if (r == 0)
+      break;
+    else if (r > 0)
+      pos += r;
+#ifdef EINTR
+    else if (errno == EINTR)
+      continue;
+#endif
+    else
+      break; /* error reading */
+  }
+
+  if (pos > 0) {
+    if (WIN32_IZE(lseek)(fd, init_pos, SEEK_SET) == -1) return Z_NULL;
+  }
+
+  if ((pos == 4)
+      && (buffer[0] == 0x04)
+      && (buffer[1] == 0x22)
+      && (buffer[2] == 0x4d)
+      && (buffer[3] == 0x18))
+    return glzdopen_input_lz4(fd, init_pos);
+
+  return glzdopen_input_gz(fd);
+}
+
+glzFile S_glzopen_input(const char *path) {
+  INT fd;
+
+  fd = WIN32_IZE(open)(path, O_RDONLY | GLZ_O_BINARY);
+
+  if (fd == -1)
+    return Z_NULL;
+  else
+    return S_glzdopen_input(fd);
+}
+
+#ifdef WIN32
+glzFile S_glzopen_input_w(const wchar_t *path) {
+  INT fd;
+
+  fd = _wopen(path, O_RDONLY | GLZ_O_BINARY);
+
+  if (fd == -1)
+    return Z_NULL;
+  else
+    return S_glzdopen_input(fd);
+}
+#endif
+
+IBOOL S_glzdirect(glzFile glz) {
+  if (glz->format == COMPRESS_GZIP)
+    return gzdirect(glz->gz);
+  else
+    return 0;
+}
+
+INT S_glzclose(glzFile glz) {
+  INT r = Z_OK, saved_errno = 0;
+  switch (glz->format) {
+    case COMPRESS_GZIP:
+      r = gzclose(glz->gz);
+      break;
+    case COMPRESS_LZ4:
+      if (glz->inputp) {
+        lz4File_in *lz4 = glz->lz4_in;
+        while (1) {
+          INT r = WIN32_IZE(close)(lz4->fd);
+#ifdef EINTR
+          if (r < 0 && errno == EINTR) continue;
+#endif
+	  if (r == 0) { saved_errno = errno; }
+          break;
+        }
+        (void)LZ4F_freeDecompressionContext(lz4->dctx);
+        free(lz4);
+      } else {
+        lz4File_out *lz4 = glz->lz4_out;
+        if (lz4->in_pos != 0) {
+          r = glzemit_lz4(lz4, lz4->in_buffer, lz4->in_pos);
+	  if (r >= 0) r = Z_OK; else { r = Z_ERRNO; saved_errno = errno; }
+        }
+        while (1) {
+          int r1 = WIN32_IZE(close)(lz4->fd);
+#ifdef EINTR
+          if (r1 < 0 && errno == EINTR) continue;
+#endif
+	  if (r == Z_OK && r1 < 0) { r = Z_ERRNO; saved_errno = errno; }
+          break;
+        }
+        free(lz4);
+      }
+      break;
+    default:
+      S_error1("S_glzclose", "unexpected compress format ~s", Sinteger(glz->format));
+  }
+  free(glz);
+  if (saved_errno) errno = saved_errno;
+  return r;
+}
+
+static INT glzread_lz4(lz4File_in *lz4, void *buffer, UINT count) {
+  while (lz4->out_pos == lz4->out_len) {
+    INT in_avail;
+
+    in_avail = lz4->in_len - lz4->in_pos;
+    if (!in_avail) {
+      while (1) {
+        in_avail = WIN32_IZE(read)(lz4->fd, lz4->in_buffer, LZ4_INPUT_PORT_IN_BUFFER_SIZE);
+        if (in_avail >= 0) {
+          lz4->in_len = in_avail;
+          lz4->in_pos = 0;
+          break;
+#ifdef EINTR
+        } else if (errno == EINTR) {
+          /* try again */
+#endif
+        } else {
+          lz4->err = Z_ERRNO;
+          return -1;
+        }
+      }
+    }
+
+    if (in_avail > 0) {
+      size_t amt, out_len = LZ4_INPUT_PORT_OUT_BUFFER_SIZE, in_len = in_avail;
+
+      /* For a large enough result buffer, try to decompress directly
+         to that buffer: */
+      if (count >= (out_len >> 1)) {
+        size_t direct_out_len = count;
+
+        if (lz4->frame_ended && lz4->in_buffer[lz4->in_pos] == 0)
+          return 0; /* count 0 after frame as stream terminator */
+
+        amt = LZ4F_decompress(lz4->dctx,
+                              buffer, &direct_out_len,
+                              lz4->in_buffer + lz4->in_pos, &in_len,
+                              NULL);
+        lz4->frame_ended = (amt == 0);
+
+        if (LZ4F_isError(amt)) {
+          lz4->err = Z_STREAM_ERROR;
+          return -1;
+        }
+
+        lz4->in_pos += (INT)in_len;
+
+        if (direct_out_len) {
+          lz4->stream_pos += direct_out_len;
+          return (INT)direct_out_len;
+        }
+
+        in_len = in_avail - in_len;
+      }
+
+      if (in_len > 0) {
+        if (lz4->frame_ended && lz4->in_buffer[lz4->in_pos] == 0)
+          return 0; /* count 0 after frame as stream terminator */
+
+        amt = LZ4F_decompress(lz4->dctx,
+                              lz4->out_buffer, &out_len,
+                              lz4->in_buffer + lz4->in_pos, &in_len,
+                              NULL);
+        lz4->frame_ended = (amt == 0);
+
+        if (LZ4F_isError(amt)) {
+          lz4->err = Z_STREAM_ERROR;
+          return -1;
+        }
+
+        lz4->in_pos += (INT)in_len;
+        lz4->out_len = (INT)out_len;
+        lz4->out_pos = 0;
+      }
+    } else {
+      /* EOF on read */
+      break;
+    }
+  }
+
+  if (lz4->out_pos < lz4->out_len) {
+    UINT amt = lz4->out_len - lz4->out_pos;
+    if (amt > count) amt = count;
+    memcpy(buffer, lz4->out_buffer + lz4->out_pos, amt);
+    lz4->out_pos += amt;
+    lz4->stream_pos += amt;
+    return amt;
+  }
+
+  return 0;
+}
+
+INT S_glzread(glzFile glz, void *buffer, UINT count) {
+  switch (glz->format) {
+    case COMPRESS_GZIP:
+      return gzread(glz->gz, buffer, count);
+    case COMPRESS_LZ4:
+      return glzread_lz4(glz->lz4_in, buffer, count);
+    default:
+      S_error1("S_glzread", "unexpected compress format ~s", Sinteger(glz->format));
+      return -1;
+  }
+}
+
+static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count) {
+  ptr tc = get_thread_context();
+  sized_buffer *cached_out_buffer;
+  char *out_buffer;
+  INT out_len, out_pos;
+  INT r = 0;
+
+  /* allocate one out_buffer (per thread) since we don't need one for each file.
+     the buffer is freed by destroy_thread. */
+  if ((cached_out_buffer = LZ4OUTBUFFER(tc)) == NULL || cached_out_buffer->size < lz4->out_buffer_size) {
+    if (cached_out_buffer != NULL) free(cached_out_buffer);
+    if ((LZ4OUTBUFFER(tc) = cached_out_buffer = malloc(sizeof(sized_buffer) + lz4->out_buffer_size)) == NULL) return -1;
+    cached_out_buffer->size = lz4->out_buffer_size;
+  }
+  out_buffer = cached_out_buffer->buffer;
+
+  out_len = (INT)LZ4F_compressFrame(out_buffer, lz4->out_buffer_size,
+                                    buffer, count,
+                                    &lz4->preferences);
+  if (LZ4F_isError(out_len)) {
+    lz4->err = Z_STREAM_ERROR;
+    return -1;
+  }
+
+  out_pos = 0;
+  while (out_pos < out_len) {
+    r = WIN32_IZE(write)(lz4->fd, out_buffer + out_pos, out_len - out_pos);
+    if (r >= 0)
+      out_pos += r;
+#ifdef EINTR
+    else if (errno == EINTR)
+      continue;
+#endif
+    else
+      break;
+  }
+
+  return r;
+}
+
+static INT glzwrite_lz4(lz4File_out *lz4, void *buffer, UINT count) {
+  UINT amt; INT r;
+
+  if ((amt = LZ4_OUTPUT_PORT_IN_BUFFER_SIZE - lz4->in_pos) > count) amt = count;
+
+  if (amt == LZ4_OUTPUT_PORT_IN_BUFFER_SIZE) {
+    /* full buffer coming from input...skip the memcpy */
+    if ((r = glzemit_lz4(lz4, buffer, LZ4_OUTPUT_PORT_IN_BUFFER_SIZE)) < 0) return 0;
+  } else {
+    memcpy(lz4->in_buffer + lz4->in_pos, buffer, amt);
+    if ((lz4->in_pos += amt) == LZ4_OUTPUT_PORT_IN_BUFFER_SIZE) {
+      lz4->in_pos = 0;
+      if ((r = glzemit_lz4(lz4, lz4->in_buffer, LZ4_OUTPUT_PORT_IN_BUFFER_SIZE)) < 0) return 0;
+    }
+  }
+
+  lz4->stream_pos += amt;
+  return amt;
+}
+
+INT S_glzwrite(glzFile glz, void *buffer, UINT count) {
+  switch (glz->format) {
+    case COMPRESS_GZIP:
+      return gzwrite(glz->gz, buffer, count);
+    case COMPRESS_LZ4:
+      return glzwrite_lz4(glz->lz4_out, buffer, count);
+    default:
+      S_error1("S_glzwrite", "unexpected compress format ~s", Sinteger(glz->format));
+      return -1;
+  }
+}
+
+long S_glzseek(glzFile glz, long offset, INT whence) {
+  switch (glz->format) {
+    case COMPRESS_GZIP:
+      return gzseek(glz->gz, offset, whence);
+    case COMPRESS_LZ4:
+      if (glz->inputp) {
+        lz4File_in *lz4 = glz->lz4_in;
+        if (whence == SEEK_CUR)
+          offset += (long)lz4->stream_pos;
+        if (offset < 0)
+          offset = 0;
+        if ((size_t)offset < lz4->stream_pos) {
+          /* rewind and read from start */
+          if (WIN32_IZE(lseek)(lz4->fd, lz4->init_pos, SEEK_SET) < 0) {
+            lz4->err = Z_ERRNO;
+            return -1;
+          }
+          LZ4F_resetDecompressionContext(lz4->dctx);
+          lz4->in_pos = 0;
+          lz4->in_len = 0;
+          lz4->out_len = 0;
+          lz4->out_pos = 0;
+          lz4->err = 0;
+          lz4->stream_pos = 0;
+        }
+        while ((size_t)offset > lz4->stream_pos) {
+          static char buffer[1024];
+          size_t amt = (size_t)offset - lz4->stream_pos;
+          if (amt > sizeof(buffer)) amt = sizeof(buffer);
+          if (glzread_lz4(lz4, buffer, (UINT)amt) < 0)
+            return -1;
+        }
+        return (long)lz4->stream_pos;
+      } else {
+        lz4File_out *lz4 = glz->lz4_out;
+        if (whence == SEEK_CUR)
+          offset += (long)lz4->stream_pos;
+        if (offset >= 0) {
+          while ((size_t)offset > lz4->stream_pos) {
+            size_t amt = (size_t)offset - lz4->stream_pos;
+            if (amt > 8) amt = 8;
+            if (glzwrite_lz4(lz4, "\0\0\0\0\0\0\0\0", (UINT)amt) < 0)
+              return -1;
+          }
+        }
+        return (long)lz4->stream_pos;
+      }
+    default:
+      S_error1("S_glzseek", "unexpected compress format ~s", Sinteger(glz->format));
+      return -1;
+  }
+}
+
+INT S_glzgetc(glzFile glz) {
+  switch (glz->format) {
+    case COMPRESS_GZIP:
+      return gzgetc(glz->gz);
+    case COMPRESS_LZ4:
+      {
+        unsigned char buffer[1];
+        INT r;
+        r = S_glzread(glz, buffer, 1);
+        if (r == 1)
+          return buffer[0];
+        else
+          return -1;
+      }
+    default:
+      S_error1("S_glzgetc", "unexpected compress format ~s", Sinteger(glz->format));
+      return -1;
+  }
+}
+
+INT S_glzungetc(INT c, glzFile glz) {
+  switch (glz->format) {
+    case COMPRESS_GZIP:
+      return gzungetc(c, glz->gz);
+    case COMPRESS_LZ4:
+      {
+        lz4File_in *lz4 = glz->lz4_in;
+        if (lz4->out_len == 0)
+          lz4->out_len = lz4->out_pos = 1;
+        if (lz4->out_pos) {
+          lz4->out_pos--;
+          lz4->out_buffer[lz4->out_pos] = c;
+          lz4->stream_pos--;
+          return c;
+        } else {
+          /* support ungetc only just after a getc, in which case there
+             should have been room */
+          return -1;
+        }
+      }
+    default:
+      S_error1("S_glzungetc", "unexpected compress format ~s", Sinteger(glz->format));
+      return -1;
+  }
+}
+
+INT S_glzrewind(glzFile glz) {
+  return S_glzseek(glz, 0, SEEK_SET);
+}
+
+void S_glzerror(glzFile glz, INT *errnum) {
+  switch (glz->format) {
+    case COMPRESS_GZIP:
+      (void)gzerror(glz->gz, errnum);
+      break;
+    case COMPRESS_LZ4:
+      if (glz->inputp)
+        *errnum = glz->lz4_in->err;
+      else
+        *errnum = glz->lz4_out->err;
+      break;
+    default:
+      S_error1("S_glzerror", "unexpected compress format ~s", Sinteger(glz->format));
+      *errnum = 0;
+  }
+}
+
+void S_glzclearerr(glzFile glz) {
+  switch (glz->format) {
+    case COMPRESS_GZIP:
+      gzclearerr(glz->gz);
+      break;
+    case COMPRESS_LZ4:
+      if (glz->inputp)
+        glz->lz4_in->err = 0;
+      else
+        glz->lz4_out->err = 0;
+      break;
+    default:
+      S_error1("S_glzerror", "unexpected compress format ~s", Sinteger(glz->format));
+  }
+}

ta6ob/c/compress-io.h

@@ -0,0 +1,26 @@
+/* compress-io.h
+ * Copyright 1984-2019 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+typedef struct glzFile_r {
+  INT fd;
+  IBOOL inputp;
+  INT format;
+  union {
+    struct gzFile_s *gz;
+    struct lz4File_in_r *lz4_in;
+    struct lz4File_out_r *lz4_out;
+  };
+} *glzFile;

ta6ob/c/config.h

@@ -0,0 +1,4 @@
+#define SCHEME_SCRIPT "scheme-script"
+#ifndef WIN32
+#define DEFAULT_HEAP_PATH "/usr/local/lib/csv%v/%m"
+#endif

ta6ob/c/externs.h

@@ -0,0 +1,415 @@
+/* externs.h
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+/* This file sets up platform-dependent includes and extern declarations
+ * for Scheme globals not intended for use outside of the system (prefixed
+ * with S_).  Scheme globals intended for use outside of the system
+ * (prefixed with S) are declared in scheme.h
+ */
+
+#include <stdlib.h>
+#include <string.h>
+#include <errno.h>
+#include <time.h>
+
+#ifndef WIN32
+#include <unistd.h>
+
+#if (machine_type == machine_type_i3qnx || machine_type == machine_type_ti3qnx)
+off64_t lseek64(int,off64_t,int);
+#endif
+
+#endif
+
+#ifdef SOLARIS
+#include <fcntl.h>
+#include <sys/wait.h>
+#include <setjmp.h>
+#endif
+
+#ifdef WIN32
+#include <fcntl.h>
+#include <direct.h> /* for _getcwd */
+#include <setjmp.h>
+#endif
+
+#if !defined(NORETURN)
+# if defined(__GNUC__) || defined(__clang__)
+#  define NORETURN __attribute__((noreturn))
+# elif defined(_MSC_VER)
+#  define NORETURN __declspec(noreturn)
+# else
+#  define NORETURN
+# endif /* defined(__GNUC__) || defined(__clang__) */
+#endif /* !defined(NORETURN) */
+
+/* external procedure declarations */
+/* prototypes gen. by ProtoGen Version 0.31 (Haydn Huntley) 1/18/93 */
+
+/* alloc.c */
+extern void S_alloc_init(void);
+extern void S_protect(ptr *p);
+extern void S_reset_scheme_stack(ptr tc, iptr n);
+extern void S_reset_allocation_pointer(ptr tc);
+extern ptr S_compute_bytes_allocated(ptr xg, ptr xs);
+extern ptr S_find_more_room(ISPC s, IGEN g, iptr n, ptr old);
+extern void S_dirty_set(ptr *loc, ptr x);
+extern void S_mark_card_dirty(uptr card, IGEN to_g);
+extern void S_scan_dirty(ptr **p, ptr **endp);
+extern void S_scan_remembered_set(void);
+extern void S_get_more_room(void);
+extern ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size);
+extern ptr S_cons_in(ISPC s, IGEN g, ptr car, ptr cdr);
+extern ptr S_symbol(ptr name);
+extern ptr S_rational(ptr n, ptr d);
+extern ptr S_tlc(ptr keyval, ptr tconc, ptr next);
+extern ptr S_vector_in(ISPC s, IGEN g, iptr n);
+extern ptr S_vector(iptr n);
+extern ptr S_fxvector(iptr n);
+extern ptr S_bytevector(iptr n);
+extern ptr S_null_immutable_vector(void);
+extern ptr S_null_immutable_fxvector(void);
+extern ptr S_null_immutable_bytevector(void);
+extern ptr S_null_immutable_string(void);
+extern ptr S_record(iptr n);
+extern ptr S_closure(ptr cod, iptr n);
+extern ptr S_mkcontinuation(ISPC s, IGEN g, ptr nuate, ptr stack,
+                iptr length, iptr clength, ptr link, ptr ret, ptr winders);
+extern ptr S_inexactnum(double rp, double ip);
+extern ptr S_exactnum(ptr a, ptr b);
+extern ptr S_thread(ptr tc);
+extern ptr S_string(const char *s, iptr n);
+extern ptr S_bignum(ptr tc, iptr n, IBOOL sign);
+extern ptr S_code(ptr tc, iptr type, iptr n);
+extern ptr S_relocation_table(iptr n);
+extern ptr S_weak_cons(ptr car, ptr cdr);
+
+/* fasl.c */
+extern void S_fasl_init(void);
+ptr S_fasl_read(INT fd, IFASLCODE situation, ptr path);
+ptr S_bv_fasl_read(ptr bv, ptr path);
+ptr S_boot_read(INT fd, const char *path);
+char *S_format_scheme_version(uptr n);
+char *S_lookup_machine_type(uptr n);
+extern void S_set_code_obj(char *who, IFASLCODE typ, ptr p, iptr n,
+             ptr x, iptr o);
+extern ptr S_get_code_obj(IFASLCODE typ, ptr p, iptr n, iptr o);
+
+/* flushcache.c */
+extern void S_record_code_mod(ptr tc, uptr addr, uptr bytes);
+extern void S_flush_instruction_cache(ptr tc);
+extern void S_flushcache_init(void);
+
+/* foreign.c */
+extern void S_foreign_init(void);
+extern void S_foreign_entry(void);
+
+/* gcwrapper.c */
+extern void S_ptr_tell(ptr p);
+extern void S_addr_tell(ptr p);
+extern void S_gc_init(void);
+#ifndef WIN32
+extern void S_register_child_process(INT child);
+#endif /* WIN32 */
+extern void S_fixup_counts(ptr counts);
+extern void S_do_gc(IGEN max_cg, IGEN min_tg, IGEN max_tg);
+extern void S_gc(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg);
+extern void S_gc_init(void);
+extern void S_set_maxgen(IGEN g);
+extern IGEN S_maxgen(void);
+extern void S_set_minfreegen(IGEN g);
+extern IGEN S_minfreegen(void);
+#ifndef WIN32
+extern void S_register_child_process(INT child);
+#endif /* WIN32 */
+extern IBOOL S_enable_object_counts(void);
+extern void S_set_enable_object_counts(IBOOL eoc);
+extern ptr S_object_counts(void);
+extern ptr S_locked_objects(void);
+extern ptr S_unregister_guardian(ptr tconc);
+extern void S_compact_heap(void);
+extern void S_check_heap(IBOOL aftergc);
+
+/* gc-011.c */
+extern void S_gc_011(ptr tc);
+
+/* gc-ocd.c */
+extern void S_gc_ocd(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg);
+
+/* gc-oce.c */
+extern void S_gc_oce(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg);
+
+/* intern.c */
+extern void S_intern_init(void);
+extern void S_resize_oblist(void);
+extern ptr S_intern(const unsigned char *s);
+extern ptr S_intern_sc(const string_char *s, iptr n, ptr name_str);
+extern ptr S_intern3(const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uame_str);
+extern void S_intern_gensym(ptr g);
+extern void S_retrofit_nonprocedure_code(void);
+
+/* io.c */
+extern IBOOL S_file_existsp(const char *inpath, IBOOL followp);
+extern IBOOL S_file_regularp(const char *inpath, IBOOL followp);
+extern IBOOL S_file_directoryp(const char *inpath, IBOOL followp);
+extern IBOOL S_file_symbolic_linkp(const char *inpath);
+#ifdef WIN32
+extern ptr S_find_files(const char *wildpath);
+#else
+extern ptr S_directory_list(const char *inpath);
+#endif
+extern char *S_malloc_pathname(const char *inpath);
+#ifdef WIN32
+extern wchar_t *S_malloc_wide_pathname(const char *inpath);
+#endif
+extern IBOOL S_fixedpathp(const char *inpath);
+
+/* compress-io.c */
+extern INT S_zlib_compress_level(INT compress_level);
+extern INT S_lz4_compress_level(INT compress_level);
+extern glzFile S_glzdopen_output(INT fd, INT compress_format, INT compress_level);
+extern glzFile S_glzdopen_input(INT fd);
+extern glzFile S_glzopen_input(const char *path);
+#ifdef WIN32
+extern glzFile S_glzopen_input_w(const wchar_t *path);
+#endif
+extern IBOOL S_glzdirect(glzFile file);
+extern INT S_glzclose(glzFile file);
+
+extern INT S_glzread(glzFile file, void *buffer, UINT count);
+extern INT S_glzwrite(glzFile file, void *buffer, UINT count);
+extern long S_glzseek(glzFile file, long offset, INT whence);
+extern INT S_glzgetc(glzFile file);
+extern INT S_glzungetc(INT c, glzFile file);
+extern INT S_glzrewind(glzFile file);
+
+extern void S_glzerror(glzFile file, INT *errnum);
+extern void S_glzclearerr(glzFile fdfile);
+
+
+/* new-io.c */
+extern INT S_gzxfile_fd(ptr x);
+extern glzFile S_gzxfile_gzfile(ptr x);
+extern ptr S_new_open_input_fd(const char *filename, IBOOL compressed);
+extern ptr S_new_open_output_fd(
+  const char *filename, INT mode,
+  IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
+  IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed);
+extern ptr S_new_open_input_output_fd(
+  const char *filename, INT mode,
+  IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
+  IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed);
+extern ptr S_close_fd(ptr file, IBOOL gzflag);
+extern ptr S_compress_input_fd(INT fd, I64 fp);
+extern ptr S_compress_output_fd(INT fd);
+
+extern ptr S_bytevector_read(ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag);
+extern ptr S_bytevector_read_nb(ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag);
+extern ptr S_bytevector_write(ptr file, ptr buffer, iptr start, iptr count, IBOOL gzflag);
+extern ptr S_put_byte(ptr file, INT byte, IBOOL gzflag);
+
+extern ptr S_get_fd_pos(ptr file, IBOOL gzflag);
+extern ptr S_set_fd_pos(ptr file, ptr pos, IBOOL gzflag);
+extern ptr S_get_fd_non_blocking(ptr file, IBOOL gzflag);
+extern ptr S_set_fd_non_blocking(ptr file, IBOOL x, IBOOL gzflag);
+extern ptr S_get_fd_length(ptr file, IBOOL gzflag);
+extern ptr S_set_fd_length(ptr file, ptr length, IBOOL gzflag);
+extern void S_new_io_init(void);
+
+extern uptr S_bytevector_compress_size(iptr s_count, INT compress_format);
+extern ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
+                                        ptr src_bv, iptr s_start, iptr s_count,
+                                        INT compress_format);
+extern ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count,
+                                          ptr src_bv, iptr s_start, iptr s_count,
+                                          INT compress_format);
+
+/* thread.c */
+extern void S_thread_init(void);
+extern ptr S_create_thread_object(const char *who, ptr p_tc);
+#ifdef PTHREADS
+extern ptr S_fork_thread(ptr thunk);
+extern scheme_mutex_t *S_make_mutex(void);
+extern void S_mutex_free(scheme_mutex_t *m);
+extern void S_mutex_acquire(scheme_mutex_t *m);
+extern INT S_mutex_tryacquire(scheme_mutex_t *m);
+extern void S_mutex_release(scheme_mutex_t *m);
+extern s_thread_cond_t *S_make_condition(void);
+extern void S_condition_free(s_thread_cond_t *c);
+extern IBOOL S_condition_wait(s_thread_cond_t *c, scheme_mutex_t *m, ptr t);
+extern INT S_activate_thread(void);
+extern void S_unactivate_thread(int mode);
+#endif
+
+/* scheme.c */
+extern void S_generic_invoke(ptr tc, ptr code);
+
+/* number.c */
+extern void S_number_init(void);
+extern ptr S_normalize_bignum(ptr x);
+extern IBOOL S_integer_valuep(ptr x);
+extern iptr S_integer_value(const char *who, ptr x);
+extern I64 S_int64_value(char *who, ptr x);
+extern IBOOL S_big_eq(ptr x, ptr y);
+extern IBOOL S_big_lt(ptr x, ptr y);
+extern ptr S_big_negate(ptr x);
+extern ptr S_add(ptr x, ptr y);
+extern ptr S_sub(ptr x, ptr y);
+extern ptr S_mul(ptr x, ptr y);
+extern ptr S_div(ptr x, ptr y);
+extern ptr S_rem(ptr x, ptr y);
+extern ptr S_trunc(ptr x, ptr y);
+extern void S_trunc_rem(ptr tc, ptr x, ptr y, ptr *q, ptr *r);
+extern ptr S_gcd(ptr x, ptr y);
+extern ptr S_ash(ptr x, ptr n);
+extern ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend);
+extern ptr S_integer_length(ptr x);
+extern ptr S_big_first_bit_set(ptr x);
+extern double S_random_double(U32 m1, U32 m2,
+               U32 m3, U32 m4, double scale);
+extern double S_floatify(ptr x);
+extern ptr S_decode_float(double d);
+extern ptr S_logand(ptr x, ptr y);
+extern ptr S_logbitp(ptr k, ptr x);
+extern ptr S_logbit0(ptr k, ptr x);
+extern ptr S_logbit1(ptr k, ptr x);
+extern ptr S_logtest(ptr x, ptr y);
+extern ptr S_logor(ptr x, ptr y);
+extern ptr S_logxor(ptr x, ptr y);
+extern ptr S_lognot(ptr x);
+
+/* prim.c */
+extern ptr S_lookup_library_entry(iptr n, IBOOL errorp);
+extern ptr S_lookup_c_entry(iptr i);
+extern void S_prim_init(void);
+
+/* prim5.c */
+extern ptr S_strerror(INT errnum);
+extern void S_prim5_init(void);
+extern void S_dump_tc(ptr tc);
+
+/* print.c */
+extern void S_print_init(void);
+extern void S_prin1(ptr x);
+
+/* schsig.c */
+extern ptr S_get_scheme_arg(ptr tc, iptr n);
+extern void S_put_scheme_arg(ptr tc, iptr n, ptr x);
+extern iptr S_continuation_depth(ptr k);
+extern ptr S_single_continuation(ptr k, iptr n);
+extern void S_split_and_resize(void);
+extern void S_handle_overflow(void);
+extern void S_handle_overflood(void);
+extern void S_handle_apply_overflood(void);
+extern void S_overflow(ptr tc, iptr frame_request);
+extern NORETURN void S_error_reset(const char *s);
+extern NORETURN void S_error_abort(const char *s);
+extern NORETURN void S_abnormal_exit(void);
+extern NORETURN void S_error(const char *who, const char *s);
+extern NORETURN void S_error1(const char *who, const char *s, ptr x);
+extern NORETURN void S_error2(const char *who, const char *s, ptr x, ptr y);
+extern NORETURN void S_error3(const char *who, const char *s, ptr x, ptr y, ptr z);
+extern NORETURN void S_boot_error(const ptr who, ptr s, ptr args);
+extern void S_handle_docall_error(void);
+extern void S_handle_arg_error(void);
+extern void S_handle_nonprocedure_symbol(void);
+extern void S_handle_values_error(void);
+extern void S_handle_mvlet_error(void);
+extern ptr S_allocate_scheme_signal_queue(void);
+extern ptr S_dequeue_scheme_signals(ptr tc);
+extern void S_register_scheme_signal(iptr sig);
+extern void S_fire_collector(void);
+extern NORETURN void S_noncontinuable_interrupt(void);
+extern void S_schsig_init(void);
+#ifdef DEFINE_MATHERR
+#include <math.h>
+extern INT matherr(struct exception *x);
+#endif /* DEFINE_MATHERR */
+
+/* segment.c */
+extern void S_segment_init(void);
+extern void *S_getmem(iptr bytes, IBOOL zerofill);
+extern void S_freemem(void *addr, iptr bytes);
+extern iptr S_find_segments(ISPC s, IGEN g, iptr n);
+extern void S_free_chunk(chunkinfo *chunk);
+extern void S_free_chunks(void);
+extern uptr S_curmembytes(void);
+extern uptr S_maxmembytes(void);
+extern void S_resetmaxmembytes(void);
+extern void S_move_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list);
+
+/* stats.c */
+extern void S_stats_init(void);
+extern ptr S_cputime(void);
+extern ptr S_realtime(void);
+extern ptr S_clock_gettime(I32 typeno);
+extern ptr S_gmtime(ptr tzoff, ptr tspair);
+extern ptr S_asctime(ptr dtvec);
+extern ptr S_mktime(ptr dtvec);
+extern ptr S_unique_id(void);
+extern void S_gettime(INT typeno, struct timespec *tp);
+
+/* symbol.c */
+extern ptr S_symbol_value(ptr sym);
+extern void S_set_symbol_value(ptr sym, ptr val);
+
+/* machine-dependent .c files, e.g., x88k.c */
+#ifdef FLUSHCACHE
+extern INT S_flushcache_max_gap(void);
+extern void S_doflush(uptr start, uptr end);
+#endif
+extern void S_machine_init(void);
+
+/* schlib.c */
+extern void S_initframe(ptr tc, iptr n);
+extern void S_put_arg(ptr tc, iptr i, ptr x);
+extern void S_return(void);
+extern void S_call_help(ptr tc, IBOOL singlep, IBOOL lock_ts);
+extern void S_call_one_result(void);
+extern void S_call_any_results(void);
+
+#ifdef WIN32
+/* windows.c */
+extern INT S_getpagesize(void);
+extern ptr S_LastErrorString(void);
+extern void *S_ntdlopen(const char *path);
+extern void *S_ntdlsym(void *h, const char *s);
+extern ptr S_ntdlerror(void);
+extern int S_windows_flock(int fd, int operation);
+extern int S_windows_chdir(const char *pathname);
+extern int S_windows_chmod(const char *pathname, int mode);
+extern int S_windows_mkdir(const char *pathname);
+extern int S_windows_open(const char *pathname, int flags, int mode);
+extern int S_windows_rename(const char *oldpathname, const char *newpathname);
+extern int S_windows_rmdir(const char *pathname);
+extern int S_windows_stat64(const char *pathname, struct STATBUF *buffer);
+extern int S_windows_system(const char *command);
+extern int S_windows_unlink(const char *pathname);
+extern char *S_windows_getcwd(char *buffer, int maxlen);
+#endif /* WIN32 */
+
+#ifdef _WIN64
+extern int S_setjmp(void* jb);
+extern void S_longjmp(void* jb, int value);
+#endif /* _WIN64 */
+
+#ifdef FEATURE_EXPEDITOR
+/* expeditor.c */
+extern void S_expeditor_init(void);
+#endif /* FEATURE_EXPEDITOR */
+
+/* statics.c */
+extern void scheme_statics(void);

ta6ob/c/flushcache.c

@@ -0,0 +1,87 @@
+/* flushcache.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+#ifdef FLUSHCACHE
+typedef struct {
+  uptr start;
+  uptr end;
+} mod_range;
+
+#define mod_range_start(x) (((mod_range *)&BVIT(x,0))->start)
+#define mod_range_end(x) (((mod_range *)&BVIT(x,0))->end)
+
+static uptr max_gap;
+
+static ptr make_mod_range(uptr start, uptr end) {
+  ptr bv = S_bytevector(sizeof(mod_range));
+  mod_range_start(bv) = start;
+  mod_range_end(bv) = end;
+  return bv;
+}
+
+/* we record info per thread so flush in one prematurely for another doesn't prevent
+   the other from doing its own flush...and also since it's not clear that flushing in one
+   actually syncs caches across cores & processors */
+
+void S_record_code_mod(ptr tc, uptr addr, uptr bytes) {
+  uptr end = addr + bytes;
+  ptr ls = CODERANGESTOFLUSH(tc);
+
+  if (ls != Snil) {
+    ptr last_mod = Scar(ls);
+    uptr last_end = mod_range_end(last_mod);
+    if (addr > last_end && addr - last_end < max_gap) {
+#ifdef DEBUG
+      printf("  record_code_mod merging %x %x and %x %x\n", mod_range_start(last_mod), last_end, addr, end); fflush(stdout);
+#endif
+      mod_range_end(last_mod) = end;
+      return;
+    }
+  }
+
+#ifdef DEBUG
+      printf("  record_code_mod new range %x to %x\n", addr, end); fflush(stdout);
+#endif
+  CODERANGESTOFLUSH(tc) = S_cons_in(space_new, 0, make_mod_range(addr, end), ls);
+  return;
+}
+
+extern void S_flush_instruction_cache(ptr tc) {
+  ptr ls;
+
+  for (ls = CODERANGESTOFLUSH(tc); ls != Snil; ls = Scdr(ls)) {
+    S_doflush(mod_range_start(Scar(ls)), mod_range_end(Scar(ls)));
+  }
+  CODERANGESTOFLUSH(tc) = Snil;
+}
+
+extern void S_flushcache_init(void) {
+  if (S_boot_time) {
+    max_gap = S_flushcache_max_gap();
+    if (max_gap < (uptr)(code_data_disp + byte_alignment)) {
+      max_gap = (uptr)(code_data_disp + byte_alignment);
+    }
+  }
+}
+#else /* FLUSHCACHE */
+
+extern void S_record_code_mod(UNUSED ptr tc, UNUSED uptr addr, UNUSED uptr bytes) {}
+extern void S_flush_instruction_cache(UNUSED ptr tc) {}
+extern void S_flushcache_init(void) { return; }
+
+#endif /* FLUSHCACHE */

ta6ob/c/foreign.c

@@ -0,0 +1,334 @@
+/* foreign.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#define debug(y) /* (void)printf(y) *//* uncomment printf for debug */
+/* #define UNLINK(x) 0 *//* uncomment #define to preserve temp files */
+
+
+#include "system.h"
+
+/* we can now return arbitrary values (aligned or not)
+ * since the garbage collector ignores addresses outside of the heap
+ * or within foreign segments */
+#define ptr_to_addr(p) ((void *)p)
+#define addr_to_ptr(a) ((ptr)a)
+
+/* buckets should be prime */
+#define buckets 457
+#define multiplier 3
+
+#define ptrhash(x) ((uptr)x % buckets)
+
+#ifdef LOAD_SHARED_OBJECT
+#if defined(HPUX)
+#include <dl.h>
+#define dlopen(path,flags) (void *)shl_load(path, BIND_IMMEDIATE, 0L)
+#define s_dlerror() Sstring_utf8(strerror(errno), -1)
+#elif defined(WIN32)
+#define dlopen(path,flags) S_ntdlopen(path)
+#define dlsym(h,s) S_ntdlsym(h,s)
+#define s_dlerror() S_ntdlerror()
+#else
+#include <dlfcn.h>
+#define s_dlerror() Sstring_utf8(dlerror(), -1)
+#ifndef RTLD_NOW
+#define RTLD_NOW 2
+#endif /* RTLD_NOW */
+#endif /* machine types */
+#endif /* LOAD_SHARED_OBJECT */
+
+/* locally defined functions */
+static uptr symhash(const char *s);
+static ptr lookup_static(const char *s);
+static ptr lookup_dynamic(const char *s, ptr tbl);
+static ptr lookup(const char *s);
+static ptr remove_foreign_entry(const char *s);
+static void *lookup_foreign_entry(const char *s);
+static ptr foreign_entries(void);
+static ptr foreign_static_table(void);
+static ptr foreign_dynamic_table(void);
+static ptr bvstring(const char *s);
+
+#ifdef LOAD_SHARED_OBJECT
+static void load_shared_object(const char *path);
+#endif /* LOAD_SHARED_OBJECT */
+
+#ifdef HPUX
+void *proc2entry(void *f, ptr name) {
+   if (((uptr)f & 2) == 0)
+      if (name == NULL)
+         S_error("Sforeign_symbol", "invalid entry");
+      else
+         S_error1("Sforeign_symbol", "invalid entry for ~s", name);
+   return (void *)((uptr)f & ~0x3);
+}
+#endif /* HPUX */
+
+static ptr bvstring(const char *s) {
+  iptr n = strlen(s) + 1;
+  ptr x = S_bytevector(n);
+  memcpy(&BVIT(x, 0), s, n);
+  return x;
+}
+
+/* multiplier weights each character, h = n factors in the length */
+static uptr symhash(const char *s) {
+  uptr n, h;
+
+  h = n = strlen(s);
+  while (n--) h = h * multiplier + (unsigned char)*s++;
+  return h % buckets;
+}
+
+static ptr lookup_static(const char *s) {
+  uptr b; ptr p;
+
+  b = symhash(s);
+  for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p))
+    if (strcmp(s, (char *)&BVIT(Scar(Scar(p)),0)) == 0)
+       return Scdr(Scar(p));
+
+  return addr_to_ptr(0);
+}
+
+#ifdef LOAD_SHARED_OBJECT
+#define LOOKUP_DYNAMIC
+static ptr lookup_dynamic(const char *s, ptr tbl) {
+    ptr p;
+
+    for (p = tbl; p != Snil; p = Scdr(p)) {
+#ifdef HPUX
+        (void *)value = (void *)0; /* assignment to prevent compiler warning */
+        shl_t handle = (shl_t)ptr_to_addr(Scar(p));
+
+        if (shl_findsym(&handle, s, TYPE_PROCEDURE, (void *)&value) == 0)
+           return addr_to_ptr(proc2entry(value, NULL));
+#else /* HPUX */
+        void *value;
+
+        value = dlsym(ptr_to_addr(Scar(p)), s);
+        if (value != (void *)0) return addr_to_ptr(value);
+#endif /* HPUX */
+    }
+
+    return addr_to_ptr(0);
+}
+#endif /* LOAD_SHARED_OBJECT */
+
+static ptr lookup(const char *s) {
+    iptr b; ptr p;
+
+#ifdef LOOKUP_DYNAMIC
+    ptr x;
+
+    x = lookup_dynamic(s, S_foreign_dynamic);
+    if (x == addr_to_ptr(0))
+#endif /* LOOKUP_DYNAMIC */
+
+    x = lookup_static(s);
+    if (x == addr_to_ptr(0)) return x;
+
+    tc_mutex_acquire()
+
+    b = ptrhash(x);
+    for (p = Svector_ref(S_G.foreign_names, b); p != Snil; p = Scdr(p)) {
+      if (Scar(Scar(p)) == x) {
+        SETCDR(Scar(p),bvstring(s));
+        goto quit;
+      }
+    }
+    SETVECTIT(S_G.foreign_names, b, Scons(Scons(addr_to_ptr(x),bvstring(s)),
+                                      Svector_ref(S_G.foreign_names, b)));
+
+quit:
+    tc_mutex_release()
+    return x;
+}
+
+void Sforeign_symbol(const char *s, void *v) {
+    iptr b; ptr x;
+
+    tc_mutex_acquire()
+
+#ifdef HPUX
+    v = proc2entry(v,name);
+#endif
+
+    if ((x = lookup(s)) == addr_to_ptr(0)) {
+        b = symhash(s);
+        SETVECTIT(S_G.foreign_static, b, Scons(Scons(bvstring(s), addr_to_ptr(v)),
+                                          Svector_ref(S_G.foreign_static, b)));
+    } else if (ptr_to_addr(x) != v)
+        S_error1("Sforeign_symbol", "duplicate symbol entry for ~s", Sstring_utf8(s, -1));
+
+    tc_mutex_release()
+}
+
+/* like Sforeign_symbol except it silently redefines the symbol
+   if it's already in S_G.foreign_static */
+void Sregister_symbol(const char *s, void *v) {
+  uptr b; ptr p;
+
+  tc_mutex_acquire()
+
+  b = symhash(s);
+  for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p))
+    if (strcmp(s, (char *)&BVIT(Scar(Scar(p)),0)) == 0) {
+       INITCDR(Scar(p)) = addr_to_ptr(v);
+       goto quit;
+    }
+  SETVECTIT(S_G.foreign_static, b, Scons(Scons(bvstring(s), addr_to_ptr(v)),
+                                      Svector_ref(S_G.foreign_static, b)));
+
+ quit:
+  tc_mutex_release()
+}
+
+static ptr remove_foreign_entry(const char *s) {
+    uptr b;
+    ptr tbl, p1, p2;
+
+    tc_mutex_acquire()
+
+    b = symhash(s);
+    tbl = S_G.foreign_static;
+    p1 = Snil;
+    p2 = Svector_ref(tbl, b);
+    for (; p2 != Snil; p1 = p2, p2 = Scdr(p2)) {
+        if (strcmp(s, (char *)&BVIT(Scar(Scar(p2)), 0)) == 0) {
+            if (p1 == Snil) {
+                SETVECTIT(tbl, b, Scdr(p2))
+            } else {
+                SETCDR(p1, Scdr(p2))
+            }
+            tc_mutex_release()
+            return Strue;
+        }
+    }
+    tc_mutex_release()
+    return Sfalse;
+}
+
+#ifdef LOAD_SHARED_OBJECT
+static void load_shared_object(const char *path) {
+    void *handle;
+
+    tc_mutex_acquire()
+
+    handle = dlopen(path, RTLD_NOW);
+    if (handle == (void *)NULL)
+        S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1), s_dlerror());
+    S_foreign_dynamic = Scons(addr_to_ptr(handle), S_foreign_dynamic);
+
+    tc_mutex_release()
+
+    return;
+}
+#endif /* LOAD_SHARED_OBJECT */
+
+void S_foreign_entry(void) {
+    ptr tc = get_thread_context();
+    ptr name, x, bvname;
+    iptr i, n;
+
+    name = AC0(tc);
+    if (Sfixnump(name) || Sbignump(name)) {
+        AC0(tc) = (ptr)Sinteger_value(name);
+        return;
+    }
+
+    if (!(Sstringp(name))) {
+        S_error1("foreign-procedure", "invalid foreign procedure handle ~s", name);
+    }
+
+    n = Sstring_length(name);
+    bvname = S_bytevector(n + 1);
+    for (i = 0; i != n; i += 1) {
+      int k = Sstring_ref(name, i);
+      if (k >= 256) k = '?';
+      BVIT(bvname, i) = k;
+    }
+    BVIT(bvname, n) = 0;
+
+    if ((x = lookup((char *)&BVIT(bvname, 0))) == addr_to_ptr(0)) {
+        S_error1("foreign-procedure", "no entry for ~s", name);
+    }
+
+    AC0(tc) = x;
+}
+
+static void *lookup_foreign_entry(s) const char *s; {
+  return ptr_to_addr(lookup(s));
+}
+
+static ptr foreign_entries(void) {
+    iptr b; ptr p, entries;
+
+    entries = Snil;
+
+    for (b = 0; b < buckets; b++)
+        for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p))
+            entries = Scons(Sstring_utf8((char *)&BVIT(Scar(Scar(p)), 0), -1), entries);
+
+    return entries;
+}
+
+static ptr foreign_static_table(void) { return S_G.foreign_static; }
+#ifdef LOAD_SHARED_OBJECT
+static ptr foreign_dynamic_table(void) { return S_foreign_dynamic; }
+#else
+static ptr foreign_dynamic_table(void) { return Sfalse; }
+#endif /* LOAD_SHARED_OBJECT */
+
+static octet *foreign_address_name(ptr addr) {
+  iptr b; ptr p;
+
+  b = ptrhash(addr);
+  for (p = Svector_ref(S_G.foreign_names, b); p != Snil; p = Scdr(p))
+    if (Scar(Scar(p)) == (ptr)addr)
+       return &BVIT(Scdr(Scar(p)),0);
+
+  return NULL;
+}
+
+void S_foreign_init(void) {
+  if (S_boot_time) {
+    S_protect(&S_G.foreign_static);
+    S_G.foreign_static = S_vector(buckets);
+    {iptr i; for (i = 0; i < buckets; i++) INITVECTIT(S_G.foreign_static,i) = Snil;}
+
+    S_protect(&S_G.foreign_names);
+    S_G.foreign_names = S_vector(buckets);
+    {iptr i; for (i = 0; i < buckets; i++) INITVECTIT(S_G.foreign_names,i) = Snil;}
+
+#ifdef LOAD_SHARED_OBJECT
+    S_protect(&S_foreign_dynamic);
+    S_foreign_dynamic = Snil;
+    Sforeign_symbol("(cs)load_shared_object", (void *)load_shared_object);
+#endif /* LOAD_SHARED_OBJECT */
+
+    Sforeign_symbol("(cs)lookup_foreign_entry", (void *)lookup_foreign_entry);
+    Sforeign_symbol("(cs)remove_foreign_entry", (void *)remove_foreign_entry);
+    Sforeign_symbol("(cs)foreign_entries", (void *)foreign_entries);
+    Sforeign_symbol("(cs)foreign_static_table", (void *)foreign_static_table);
+    Sforeign_symbol("(cs)foreign_dynamic_table", (void *)foreign_dynamic_table);
+    Sforeign_symbol("(cs)foreign_address_name", (void *)foreign_address_name);
+  }
+
+#ifdef LOAD_SHARED_OBJECT
+  S_foreign_dynamic = Snil;
+#endif /* LOAD_SHARED_OBJECT */
+}

ta6ob/c/gc-011.c

@@ -0,0 +1,23 @@
+/* gc-011.c
+ * Copyright 1984-2020 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#define GCENTRY S_gc_011
+#define MAX_CG 0
+#define MIN_TG 1
+#define MAX_TG 1
+#define compute_target_generation(g) 1
+#define NO_LOCKED_OLDSPACE_OBJECTS
+#include "gc.c"

ta6ob/c/gc-ocd.c

@@ -0,0 +1,18 @@
+/* gc-ocd.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#define GCENTRY S_gc_ocd
+#include "gc.c"

ta6ob/c/gc-oce.c

@@ -0,0 +1,19 @@
+/* gc-oce.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#define GCENTRY S_gc_oce
+#define ENABLE_OBJECT_COUNTS
+#include "gc.c"

ta6ob/c/gcwrapper.c

@@ -0,0 +1,864 @@
+/* gcwrapper.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+/* locally defined functions */
+static IBOOL memqp(ptr x, ptr ls);
+static IBOOL remove_first_nomorep(ptr x, ptr *pls, IBOOL look);
+static void segment_tell(uptr seg);
+static void check_heap_dirty_msg(char *msg, ptr *x);
+static IBOOL dirty_listedp(seginfo *x, IGEN from_g, IGEN to_g);
+static void check_dirty_space(ISPC s);
+static void check_dirty(void);
+
+static IBOOL checkheap_noisy;
+
+void S_gc_init(void) {
+  IGEN g; INT i;
+
+  S_checkheap = 0; /* 0 for disabled, 1 for enabled */
+  S_checkheap_errors = 0; /* count of errors detected by checkheap */
+  checkheap_noisy = 0; /* 0 for error output only; 1 for more noisy output */
+  S_G.prcgeneration = static_generation;
+
+  if (S_checkheap) {
+    printf(checkheap_noisy ? "NB: check_heap is enabled and noisy\n" : "NB: check_heap_is_enabled\n");
+    fflush(stdout);
+  }
+
+#ifndef WIN32
+  for (g = 0; g <= static_generation; g++) {
+    S_child_processes[g] = Snil;
+  }
+#endif /* WIN32 */
+
+  if (!S_boot_time) return;
+
+  for (g = 0; g <= static_generation; g++) {
+    S_G.guardians[g] = Snil;
+    S_G.locked_objects[g] = Snil;
+    S_G.unlocked_objects[g] = Snil;
+  }
+  S_G.max_nonstatic_generation = 
+    S_G.new_max_nonstatic_generation = 
+      S_G.min_free_gen = 
+        S_G.new_min_free_gen = default_max_nonstatic_generation;
+
+  for (g = 0; g <= static_generation; g += 1) {
+    for (i = 0; i < countof_types; i += 1) {
+      S_G.countof[g][i] = 0;
+      S_G.bytesof[g][i] = 0;
+    }
+    S_G.gctimestamp[g] = 0;
+    S_G.rtds_with_counts[g] = Snil;
+  }
+
+  S_G.countof[static_generation][countof_oblist] += 1;
+  S_G.bytesof[static_generation][countof_oblist] += S_G.oblist_length * sizeof(bucket *);
+
+  S_protect(&S_G.static_id);
+  S_G.static_id = S_intern((const unsigned char *)"static");
+
+  S_protect(&S_G.countof_names);
+  S_G.countof_names = S_vector(countof_types);
+  for (i = 0; i < countof_types; i += 1) {
+    INITVECTIT(S_G.countof_names, i) = FIX(0);
+    S_G.countof_size[i] = 0;
+  }
+  INITVECTIT(S_G.countof_names, countof_pair) = S_intern((const unsigned char *)"pair");
+    S_G.countof_size[countof_pair] = size_pair;
+  INITVECTIT(S_G.countof_names, countof_symbol) = S_intern((const unsigned char *)"symbol");
+    S_G.countof_size[countof_symbol] = size_symbol;
+  INITVECTIT(S_G.countof_names, countof_flonum) = S_intern((const unsigned char *)"flonum");
+    S_G.countof_size[countof_flonum] = size_flonum;
+  INITVECTIT(S_G.countof_names, countof_closure) = S_intern((const unsigned char *)"procedure");
+    S_G.countof_size[countof_closure] = 0;
+  INITVECTIT(S_G.countof_names, countof_continuation) = S_intern((const unsigned char *)"continuation");
+    S_G.countof_size[countof_continuation] = size_continuation;
+  INITVECTIT(S_G.countof_names, countof_bignum) = S_intern((const unsigned char *)"bignum");
+    S_G.countof_size[countof_bignum] = 0;
+  INITVECTIT(S_G.countof_names, countof_ratnum) = S_intern((const unsigned char *)"ratnum");
+    S_G.countof_size[countof_ratnum] = size_ratnum;
+  INITVECTIT(S_G.countof_names, countof_inexactnum) = S_intern((const unsigned char *)"inexactnum");
+    S_G.countof_size[countof_inexactnum] = size_inexactnum;
+  INITVECTIT(S_G.countof_names, countof_exactnum) = S_intern((const unsigned char *)"exactnum");
+    S_G.countof_size[countof_exactnum] = size_exactnum;
+  INITVECTIT(S_G.countof_names, countof_box) = S_intern((const unsigned char *)"box");
+    S_G.countof_size[countof_box] = size_box;
+  INITVECTIT(S_G.countof_names, countof_port) = S_intern((const unsigned char *)"port");
+    S_G.countof_size[countof_port] = size_port;
+  INITVECTIT(S_G.countof_names, countof_code) = S_intern((const unsigned char *)"code");
+    S_G.countof_size[countof_code] = 0;
+  INITVECTIT(S_G.countof_names, countof_thread) = S_intern((const unsigned char *)"thread");
+    S_G.countof_size[countof_thread] = size_thread;
+  INITVECTIT(S_G.countof_names, countof_tlc) = S_intern((const unsigned char *)"tlc");
+    S_G.countof_size[countof_tlc] = size_tlc;
+  INITVECTIT(S_G.countof_names, countof_rtd_counts) = S_intern((const unsigned char *)"rtd-counts");
+    S_G.countof_size[countof_rtd_counts] = size_rtd_counts;
+  INITVECTIT(S_G.countof_names, countof_stack) = S_intern((const unsigned char *)"stack");
+    S_G.countof_size[countof_stack] = 0;
+  INITVECTIT(S_G.countof_names, countof_relocation_table) = S_intern((const unsigned char *)"reloc-table");
+    S_G.countof_size[countof_relocation_table] = 0;
+  INITVECTIT(S_G.countof_names, countof_weakpair) = S_intern((const unsigned char *)"weakpair");
+    S_G.countof_size[countof_weakpair] = size_pair;
+  INITVECTIT(S_G.countof_names, countof_vector) = S_intern((const unsigned char *)"vector");
+    S_G.countof_size[countof_vector] = 0;
+  INITVECTIT(S_G.countof_names, countof_string) = S_intern((const unsigned char *)"string");
+    S_G.countof_size[countof_string] = 0;
+  INITVECTIT(S_G.countof_names, countof_fxvector) = S_intern((const unsigned char *)"fxvector");
+    S_G.countof_size[countof_fxvector] = 0;
+  INITVECTIT(S_G.countof_names, countof_bytevector) = S_intern((const unsigned char *)"bytevector");
+    S_G.countof_size[countof_bytevector] = 0;
+  INITVECTIT(S_G.countof_names, countof_locked) = S_intern((const unsigned char *)"locked");
+    S_G.countof_size[countof_locked] = 0;
+  INITVECTIT(S_G.countof_names, countof_guardian) = S_intern((const unsigned char *)"guardian");
+    S_G.countof_size[countof_guardian] = size_guardian_entry;
+  INITVECTIT(S_G.countof_names, countof_oblist) = S_intern((const unsigned char *)"oblist");
+    S_G.countof_size[countof_guardian] = 0;
+  INITVECTIT(S_G.countof_names, countof_ephemeron) = S_intern((const unsigned char *)"ephemron");
+    S_G.countof_size[countof_ephemeron] = 0;
+  for (i = 0; i < countof_types; i += 1) {
+    if (Svector_ref(S_G.countof_names, i) == FIX(0)) {
+      fprintf(stderr, "uninitialized countof_name at index %d\n", i);
+      S_abnormal_exit();
+    }
+  }
+}
+
+IGEN S_maxgen(void) {
+  return S_G.new_max_nonstatic_generation;
+}
+
+void S_set_maxgen(IGEN g) {
+  if (g < 0 || g >= static_generation) {
+    fprintf(stderr, "invalid maxgen %d\n", g);
+    S_abnormal_exit();
+  }
+  if (S_G.new_min_free_gen == S_G.new_max_nonstatic_generation || S_G.new_min_free_gen > g) {
+    S_G.new_min_free_gen = g;
+  }
+  S_G.new_max_nonstatic_generation = g;
+}
+
+IGEN S_minfreegen(void) {
+  return S_G.new_min_free_gen;
+}
+
+void S_set_minfreegen(IGEN g) {
+  S_G.new_min_free_gen = g;
+  if (S_G.new_max_nonstatic_generation == S_G.max_nonstatic_generation) {
+    S_G.min_free_gen = g;
+  }
+}
+
+static IBOOL memqp(ptr x, ptr ls) {
+  for (;;) {
+    if (ls == Snil) return 0;
+    if (Scar(ls) == x) return 1;
+    ls = Scdr(ls);
+  }
+}
+
+static IBOOL remove_first_nomorep(ptr x, ptr *pls, IBOOL look) {
+  ptr ls;
+
+  for (;;) {
+    ls = *pls;
+    if (ls == Snil) break;
+    if (Scar(ls) == x) {
+      ls = Scdr(ls);
+      *pls = ls;
+      if (look) return !memqp(x, ls);
+      break;
+    }
+    pls = &Scdr(ls);
+  }
+
+ /* must return 0 if we don't look for more */
+  return 0;
+}
+
+IBOOL Slocked_objectp(ptr x) {
+  seginfo *si; IGEN g; IBOOL ans; ptr ls;
+
+  if (IMMEDIATE(x) || (si = MaybeSegInfo(ptr_get_segment(x))) == NULL || (g = si->generation) == static_generation) return 1;
+
+  tc_mutex_acquire()
+
+  ans = 0;
+  for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) {
+    if (x == Scar(ls)) {
+      ans = 1;
+      break;
+    }
+  }
+
+  tc_mutex_release()
+
+  return ans;
+}
+
+ptr S_locked_objects(void) {
+  IGEN g; ptr ans; ptr ls;
+
+  tc_mutex_acquire()
+
+  ans = Snil;
+  for (g = 0; g <= static_generation; INCRGEN(g)) {
+    for (ls = S_G.locked_objects[g]; ls != Snil; ls = Scdr(ls)) {
+      ans = Scons(Scar(ls), ans);
+    }
+  }
+
+  tc_mutex_release()
+
+  return ans;
+}
+
+void Slock_object(ptr x) {
+  seginfo *si; IGEN g;
+
+  tc_mutex_acquire()
+
+ /* weed out pointers that won't be relocated */
+  if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) {
+    S_pants_down += 1;
+   /* add x to locked list. remove from unlocked list */
+    S_G.locked_objects[g] = S_cons_in((g == 0 ? space_new : space_impure), g, x, S_G.locked_objects[g]);
+    if (S_G.enable_object_counts) {
+      if (g != 0) S_G.countof[g][countof_pair] += 1;
+    }
+    if (si->space & space_locked)
+      (void)remove_first_nomorep(x, &S_G.unlocked_objects[g], 0);
+    S_pants_down -= 1;
+  }
+
+  tc_mutex_release()
+}
+
+void Sunlock_object(ptr x) {
+  seginfo *si; IGEN g;
+
+  tc_mutex_acquire()
+
+  if (!IMMEDIATE(x) && (si = MaybeSegInfo(ptr_get_segment(x))) != NULL && (g = si->generation) != static_generation) {
+    S_pants_down += 1;
+   /* remove first occurrence of x from locked list. if there are no
+      others, add x to unlocked list */
+    if (remove_first_nomorep(x, &S_G.locked_objects[g], si->space & space_locked)) {
+      S_G.unlocked_objects[g] = S_cons_in((g == 0 ? space_new : space_impure), g, x, S_G.unlocked_objects[g]);
+      if (S_G.enable_object_counts) {
+        if (g != 0) S_G.countof[g][countof_pair] += 1;
+      }
+    }
+    S_pants_down -= 1;
+  }
+
+  tc_mutex_release()
+}
+
+ptr s_help_unregister_guardian(ptr *pls, ptr tconc, ptr result) {
+  ptr rep, ls;
+  while ((ls = *pls) != Snil) {
+    if (GUARDIANTCONC(ls) == tconc) {
+      result = Scons(((rep = GUARDIANREP(ls)) == ftype_guardian_rep ? GUARDIANOBJ(ls) : rep), result);
+      *pls = ls = GUARDIANNEXT(ls);
+    } else {
+      ls = *(pls = &GUARDIANNEXT(ls));
+    }
+  }
+  return result;
+}
+
+ptr S_unregister_guardian(ptr tconc) {
+  ptr result, tc; IGEN g;
+  tc_mutex_acquire()
+  tc = get_thread_context();
+  /* in the interest of thread safety, gather entries only in the current thread, ignoring any others */
+  result = s_help_unregister_guardian(&GUARDIANENTRIES(tc), tconc, Snil);
+  /* plus, of course, any already known to the storage-management system */
+  for (g = 0; g <= static_generation; INCRGEN(g)) {
+    result = s_help_unregister_guardian(&S_G.guardians[g], tconc, result);
+  }
+  tc_mutex_release()
+  return result;
+}
+
+#ifndef WIN32
+void S_register_child_process(INT child) {
+  tc_mutex_acquire()
+  S_child_processes[0] = Scons(FIX(child), S_child_processes[0]);
+  tc_mutex_release()
+}
+#endif /* WIN32 */
+
+IBOOL S_enable_object_counts(void) {
+  return S_G.enable_object_counts;
+}
+
+void S_set_enable_object_counts(IBOOL eoc) {
+  S_G.enable_object_counts = eoc;
+}
+
+ptr S_object_counts(void) {
+  IGEN grtd, g; ptr ls; iptr i; ptr outer_alist;
+
+  tc_mutex_acquire()
+
+  outer_alist = Snil;
+
+ /* add rtds w/nonozero counts to the alist */
+  for (grtd = 0; grtd <= static_generation; INCRGEN(grtd)) {
+    for (ls = S_G.rtds_with_counts[grtd]; ls != Snil; ls = Scdr(ls)) {
+      ptr rtd = Scar(ls);
+      ptr counts = RECORDDESCCOUNTS(rtd);
+      IGEN g;
+      uptr size = size_record_inst(UNFIX(RECORDDESCSIZE(rtd)));
+      ptr inner_alist = Snil;
+
+      S_fixup_counts(counts);
+      for (g = 0; g <= static_generation; INCRGEN(g)) {
+        uptr count = RTDCOUNTSIT(counts, g); IGEN gcurrent = g;
+        if (g == S_G.new_max_nonstatic_generation) {
+          while (g < S_G.max_nonstatic_generation) {
+            g += 1;
+            count += RTDCOUNTSIT(counts, g);
+          }
+        }
+        if (count != 0) inner_alist = Scons(Scons((gcurrent == static_generation ? S_G.static_id : FIX(gcurrent)), Scons(Sunsigned(count), Sunsigned(count * size))), inner_alist);
+      }
+      if (inner_alist != Snil) outer_alist = Scons(Scons(rtd, inner_alist), outer_alist);
+    }
+  }
+
+ /* add primary types w/nonozero counts to the alist */
+  for (i = 0 ; i < countof_types; i += 1) {
+    ptr inner_alist = Snil;
+    for (g = 0; g <= static_generation; INCRGEN(g)) {
+      IGEN gcurrent = g;
+      uptr count = S_G.countof[g][i];
+      uptr bytes = S_G.bytesof[g][i];
+
+      if (g == S_G.new_max_nonstatic_generation) {
+        while (g < S_G.max_nonstatic_generation) {
+          g += 1;
+          /* NB: S_G.max_nonstatic_generation + 1 <= static_generation, but coverity complains about overrun */
+          /* coverity[overrun-buffer-val] */
+          count += S_G.countof[g][i];
+          /* coverity[overrun-buffer-val] */
+          bytes += S_G.bytesof[g][i];
+        }
+      }
+
+      if (count != 0) {
+        if (bytes == 0) bytes = count * S_G.countof_size[i];
+        inner_alist = Scons(Scons((gcurrent == static_generation ? S_G.static_id : FIX(gcurrent)), Scons(Sunsigned(count), Sunsigned(bytes))), inner_alist);
+      }
+    }
+    if (inner_alist != Snil) outer_alist = Scons(Scons(Svector_ref(S_G.countof_names, i), inner_alist), outer_alist);
+  }
+
+  tc_mutex_release()
+
+  return outer_alist;
+}
+
+/* Scompact_heap().  Compact into as few O/S chunks as possible and
+ * move objects into static generation
+ */
+void Scompact_heap(void) {
+  ptr tc = get_thread_context();
+  S_pants_down += 1;
+  S_gc_oce(tc, S_G.max_nonstatic_generation, static_generation, static_generation);
+  S_pants_down -= 1;
+}
+
+/* S_check_heap checks for various kinds of heap consistency
+   It currently checks for:
+       dangling references in space_impure (generation > 0) and space_pure
+       extra dirty bits
+       missing dirty bits
+
+   Some additional things it should check for but doesn't:
+       correct dirty bytes, following sweep_dirty conventions
+       dangling references in in space_code and space_continuation
+       dirty bits set for non-impure segments outside of generation zero
+       proper chaining of segments of a space and generation:
+          chains contain all and only the appropriate segments
+
+   If noisy is nonzero, additional comments may be included in the output
+*/
+
+static void segment_tell(uptr seg) {
+  seginfo *si;
+  ISPC s, s1;
+  static char *spacename[max_space+1] = { alloc_space_names };
+
+  printf("segment %#tx", (ptrdiff_t)seg);
+  if ((si = MaybeSegInfo(seg)) == NULL) {
+    printf(" out of heap bounds\n");
+  } else {
+    printf(" generation=%d", si->generation);
+    s = si->space;
+    s1 = si->space & ~(space_old|space_locked);
+    if (s1 < 0 || s1 > max_space)
+      printf(" space-bogus (%d)", s);
+    else {
+      printf(" space-%s", spacename[s1]);
+      if (s & space_old) printf(" oldspace");
+      if (s & space_locked) printf(" locked");
+    }
+    printf("\n");
+  }
+  fflush(stdout);
+}
+
+void S_ptr_tell(ptr p) {
+  segment_tell(ptr_get_segment(p));
+}
+
+void S_addr_tell(ptr p) {
+  segment_tell(addr_get_segment(p));
+}
+
+static void check_heap_dirty_msg(char *msg, ptr *x) {
+    INT d; seginfo *si;
+
+    si = SegInfo(addr_get_segment(x));
+    d = (INT)(((uptr)x >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1));
+    printf("%s dirty byte %d found in segment %#tx, card %d at %#tx\n", msg, si->dirty_bytes[d], (ptrdiff_t)(si->number), d, (ptrdiff_t)x);
+    printf("from "); segment_tell(addr_get_segment(x));
+    printf("to   "); segment_tell(addr_get_segment(*x));
+}
+
+void S_check_heap(IBOOL aftergc) {
+  uptr seg; INT d; ISPC s; IGEN g; IDIRTYBYTE dirty; IBOOL found_eos; IGEN pg;
+  ptr p, *pp1, *pp2, *nl;
+  iptr i;
+  uptr empty_segments = 0;
+  uptr used_segments = 0;
+  uptr static_segments = 0;
+  uptr nonstatic_segments = 0;
+
+  check_dirty();
+
+  for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) {
+    chunkinfo *chunk = i == -1 ? S_chunks_full : S_chunks[i];
+    while (chunk != NULL) {
+      seginfo *si = chunk->unused_segs;
+      iptr count = 0;
+      while(si) {
+        count += 1;
+        if (si->space != space_empty) {
+          S_checkheap_errors += 1;
+          printf("!!! unused segment has unexpected space\n");
+        }
+        si = si->next;
+      }
+      if ((chunk->segs - count) != chunk->nused_segs) {
+        S_checkheap_errors += 1;
+        printf("!!! unexpected used segs count %td with %td total segs and %td segs on the unused list\n",
+            (ptrdiff_t)chunk->nused_segs, (ptrdiff_t)chunk->segs, (ptrdiff_t)count);
+      }
+      used_segments += chunk->nused_segs;
+      empty_segments += count;
+      chunk = chunk->next;
+    }
+  }
+
+  for (s = 0; s <= max_real_space; s += 1) {
+    seginfo *si;
+    for (g = 0; g <= S_G.max_nonstatic_generation; INCRGEN(g)) {
+      for (si = S_G.occupied_segments[g][s]; si != NULL; si = si->next) {
+        nonstatic_segments += 1;
+      }
+    }
+    for (si = S_G.occupied_segments[static_generation][s]; si != NULL; si = si->next) {
+      static_segments += 1;
+    }
+  }
+
+  if (used_segments != nonstatic_segments + static_segments) {
+    S_checkheap_errors += 1;
+    printf("!!! found %#tx used segments and %#tx occupied segments\n",
+        (ptrdiff_t)used_segments,
+        (ptrdiff_t)(nonstatic_segments + static_segments));
+  }
+
+  if (S_G.number_of_nonstatic_segments != nonstatic_segments) {
+    S_checkheap_errors += 1;
+    printf("!!! S_G.number_of_nonstatic_segments %#tx is different from occupied number %#tx\n",
+        (ptrdiff_t)S_G.number_of_nonstatic_segments,
+        (ptrdiff_t)nonstatic_segments);
+  }
+
+  if (S_G.number_of_empty_segments != empty_segments) {
+    S_checkheap_errors += 1;
+    printf("!!! S_G.number_of_empty_segments %#tx is different from unused number %#tx\n",
+        (ptrdiff_t)S_G.number_of_empty_segments,
+        (ptrdiff_t)empty_segments);
+  }
+
+  for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) {
+    chunkinfo *chunk = i == -1 ? S_chunks_full : S_chunks[i];
+    while (chunk != NULL) {
+      uptr nsegs; seginfo *si;
+      for (si = &chunk->sis[0], nsegs = chunk->segs; nsegs != 0; nsegs -= 1, si += 1) {
+        seginfo *recorded_si; uptr recorded_seg;
+        if ((seg = si->number) != (recorded_seg = (chunk->base + chunk->segs - nsegs))) {
+          S_checkheap_errors += 1;
+          printf("!!! recorded segment number %#tx differs from actual segment number %#tx", (ptrdiff_t)seg, (ptrdiff_t)recorded_seg);
+        }
+        if ((recorded_si = SegInfo(seg)) != si) {
+          S_checkheap_errors += 1;
+          printf("!!! recorded segment %#tx seginfo %#tx differs from actual seginfo %#tx", (ptrdiff_t)seg, (ptrdiff_t)recorded_si, (ptrdiff_t)si);
+        }
+        s = si->space;
+        g = si->generation;
+
+        if (s == space_new) {
+          if (g != 0) {
+            S_checkheap_errors += 1;
+            printf("!!! unexpected generation %d segment %#tx in space_new\n", g, (ptrdiff_t)seg);
+          }
+        } else if (s == space_impure || s == space_symbol || s == space_pure || s == space_weakpair /* || s == space_ephemeron */) {
+          /* out of date: doesn't handle space_port, space_continuation, space_code, space_pure_typed_object, space_impure_record */
+          nl = (ptr *)S_G.next_loc[g][s];
+
+          /* check for dangling references */
+          pp1 = (ptr *)build_ptr(seg, 0);
+          pp2 = (ptr *)build_ptr(seg + 1, 0);
+          if (pp1 <= nl && nl < pp2) pp2 = nl;
+
+          while (pp1 != pp2) {
+            seginfo *psi; ISPC ps;
+            p = *pp1;
+            if (p == forward_marker) break;
+            if (!IMMEDIATE(p) && (psi = MaybeSegInfo(ptr_get_segment(p))) != NULL && ((ps = psi->space) & space_old || ps == space_empty)) {
+              S_checkheap_errors += 1;
+              printf("!!! dangling reference at %#tx to %#tx\n", (ptrdiff_t)pp1, (ptrdiff_t)p);
+              printf("from: "); segment_tell(seg);
+              printf("to:   "); segment_tell(ptr_get_segment(p));
+            }
+            pp1 += 1;
+          }
+
+          /* verify that dirty bits are set appropriately */
+          /* out of date: doesn't handle space_impure_record, space_port, and maybe others */
+          /* also doesn't check the SYMCODE for symbols */
+          if (s == space_impure || s == space_symbol || s == space_weakpair /* || s == space_ephemeron */) {
+            found_eos = 0;
+            pp2 = pp1 = build_ptr(seg, 0);
+            for (d = 0; d < cards_per_segment; d += 1) {
+              if (found_eos) {
+                if (si->dirty_bytes[d] != 0xff) {
+                  S_checkheap_errors += 1;
+                  printf("!!! Dirty byte set past end-of-segment for segment %#tx, card %d\n", (ptrdiff_t)seg, d);
+                  segment_tell(seg);
+                }
+                continue;
+              }
+
+              pp2 += bytes_per_card / sizeof(ptr);
+              if (pp1 <= nl && nl < pp2) {
+                found_eos = 1;
+                pp2 = nl;
+              }
+
+#ifdef DEBUG
+              printf("pp1 = %#tx, pp2 = %#tx, nl = %#tx\n", (ptrdiff_t)pp1, (ptrdiff_t)pp2, (ptrdiff_t)nl);
+              fflush(stdout);
+#endif
+
+              dirty = 0xff;
+              while (pp1 != pp2) {
+                seginfo *psi;
+                p = *pp1;
+
+                if (p == forward_marker) {
+                  found_eos = 1;
+                  break;
+                }
+                if (!IMMEDIATE(p) && (psi = MaybeSegInfo(ptr_get_segment(p))) != NULL && (pg = psi->generation) < g) {
+                  if (pg < dirty) dirty = pg;
+                  if (si->dirty_bytes[d] > pg) {
+                    S_checkheap_errors += 1;
+                    check_heap_dirty_msg("!!! INVALID", pp1);
+                  }
+                  else if (checkheap_noisy)
+                    check_heap_dirty_msg("... ", pp1);
+                }
+                pp1 += 1;
+              }
+              if (checkheap_noisy && si->dirty_bytes[d] < dirty) {
+                /* sweep_dirty won't sweep, and update dirty byte, for
+                   cards with dirty pointers to segments older than the
+                   maximum copied generation, so we can get legitimate
+                   conservative dirty bytes even after gc */
+                printf("... Conservative dirty byte %x (%x) %sfor segment %#tx card %d ",
+                    si->dirty_bytes[d], dirty,
+                    (aftergc ? "after gc " : ""),
+                    (ptrdiff_t)seg, d);
+                segment_tell(seg);
+              }
+            }
+          }
+        }
+        if (aftergc && s != space_empty && !(s & space_locked) && (g == 0 || (s != space_impure && s != space_symbol && s != space_port && s != space_weakpair && s != space_ephemeron && s != space_impure_record))) {
+          for (d = 0; d < cards_per_segment; d += 1) {
+            if (si->dirty_bytes[d] != 0xff) {
+              S_checkheap_errors += 1;
+              printf("!!! Unnecessary dirty byte %x (%x) after gc for segment %#tx card %d ",
+                  si->dirty_bytes[d], 0xff, (ptrdiff_t)(si->number), d);
+              segment_tell(seg);
+            }
+          }
+        }
+      }
+      chunk = chunk->next;
+    }
+  }
+}
+
+static IBOOL dirty_listedp(seginfo *x, IGEN from_g, IGEN to_g) {
+  seginfo *si = DirtySegments(from_g, to_g);
+  while (si != NULL) {
+    if (si == x) return 1;
+    si = si->dirty_next;
+  }
+  return 0;
+}
+
+static void check_dirty_space(ISPC s) {
+  IGEN from_g, to_g, min_to_g; INT d; seginfo *si;
+
+  for (from_g = 0; from_g <= static_generation; from_g += 1) {
+    for (si = S_G.occupied_segments[from_g][s]; si != NULL; si = si->next) {
+      if (si->space & space_locked) continue;
+      min_to_g = 0xff;
+      for (d = 0; d < cards_per_segment; d += 1) {
+        to_g = si->dirty_bytes[d];
+        if (to_g != 0xff) {
+          if (to_g < min_to_g) min_to_g = to_g;
+          if (from_g == 0) {
+            S_checkheap_errors += 1;
+            printf("!!! (check_dirty): space %d, generation %d segment %#tx card %d is marked dirty\n", s, from_g, (ptrdiff_t)(si->number), d);
+          }
+        }
+      }
+      if (min_to_g != si->min_dirty_byte) {
+        S_checkheap_errors += 1;
+        printf("!!! (check_dirty): space %d, generation %d segment %#tx min_dirty_byte is %d while actual min is %d\n",  s, from_g, (ptrdiff_t)(si->number), si->min_dirty_byte, min_to_g);
+        segment_tell(si->number);
+      } else if (min_to_g != 0xff) {
+        if (!dirty_listedp(si, from_g, min_to_g)) {
+          S_checkheap_errors += 1;
+          printf("!!! (check_dirty): space %d, generation %d segment %#tx is marked dirty but not in dirty-segment list\n", s, from_g, (ptrdiff_t)(si->number));
+          segment_tell(si->number);
+        }
+      }
+    }
+  }
+}
+
+static void check_dirty(void) {
+  IGEN from_g, to_g; seginfo *si;
+
+  for (from_g = 1; from_g <= static_generation; from_g = from_g == S_G.max_nonstatic_generation ? static_generation : from_g + 1) {
+    for (to_g = 0; (from_g == static_generation) ? (to_g <= S_G.max_nonstatic_generation) : (to_g < from_g); to_g += 1) {
+      si = DirtySegments(from_g, to_g);
+      if (from_g > S_G.max_nonstatic_generation && from_g != static_generation) {
+        if (si != NULL) {
+          S_checkheap_errors += 1;
+          printf("!!! (check_dirty): unexpected nonempty from-generation %d, to-generation %d dirty segment list\n", from_g, to_g);
+        }
+      } else {
+        while (si != NULL) {
+          ISPC s = si->space & ~space_locked;
+          IGEN g = si->generation;
+          IGEN mingval = si->min_dirty_byte;
+          if (g != from_g) {
+            S_checkheap_errors += 1;
+            printf("!!! (check_dirty): generation %d segment %#tx in %d -> %d dirty list\n", g, (ptrdiff_t)(si->number), from_g, to_g);
+          }
+          if (mingval != to_g) {
+            S_checkheap_errors += 1;
+            printf("!!! (check_dirty): dirty byte = %d for segment %#tx in %d -> %d dirty list\n", mingval, (ptrdiff_t)(si->number), from_g, to_g);
+          }
+          if (s != space_new && s != space_impure && s != space_symbol && s != space_port && s != space_impure_record && s != space_weakpair && s != space_ephemeron) {
+            S_checkheap_errors += 1;
+            printf("!!! (check_dirty): unexpected space %d for dirty segment %#tx\n", s, (ptrdiff_t)(si->number));
+          }
+          si = si->dirty_next;
+        }
+      }
+    }
+  }
+
+  check_dirty_space(space_impure);
+  check_dirty_space(space_symbol);
+  check_dirty_space(space_port);
+  check_dirty_space(space_impure_record);
+  check_dirty_space(space_weakpair);
+  check_dirty_space(space_ephemeron);
+
+  fflush(stdout);
+}
+
+void S_fixup_counts(ptr counts) {
+  IGEN g; U64 timestamp;
+
+  timestamp = RTDCOUNTSTIMESTAMP(counts);
+  for (g = 0; g <= static_generation; INCRGEN(g)) {
+    if (timestamp >= S_G.gctimestamp[g]) break;
+    RTDCOUNTSIT(counts, g) = 0;
+  }
+  RTDCOUNTSTIMESTAMP(counts) = S_G.gctimestamp[0];
+}
+
+void S_do_gc(IGEN max_cg, IGEN min_tg, IGEN max_tg) {
+  ptr tc = get_thread_context();
+  ptr code;
+
+  code = CP(tc);
+  if (Sprocedurep(code)) code = CLOSCODE(code);
+  Slock_object(code);
+
+ /* Scheme side grabs mutex before calling S_do_gc */
+  S_pants_down += 1;
+
+  if (S_G.new_max_nonstatic_generation > S_G.max_nonstatic_generation) {
+    S_G.min_free_gen = S_G.new_min_free_gen;
+    S_G.max_nonstatic_generation = S_G.new_max_nonstatic_generation;
+  }
+
+  if (max_tg == max_cg && max_cg == S_G.new_max_nonstatic_generation && max_cg < S_G.max_nonstatic_generation) {
+    IGEN new_g, old_g, from_g, to_g; ISPC s; seginfo *si, *nextsi, *tail;
+   /* reducing max_nonstatic_generation */
+    new_g = S_G.new_max_nonstatic_generation;
+    old_g = S_G.max_nonstatic_generation;
+   /* first, collect everything to old_g, ignoring min_tg */
+    S_gc(tc, old_g, old_g, old_g);
+   /* now transfer old_g info to new_g, and clear old_g info */
+    S_G.bytes_of_generation[new_g] = S_G.bytes_of_generation[old_g]; S_G.bytes_of_generation[old_g] = 0;
+    for (s = 0; s <= max_real_space; s += 1) {
+      S_G.first_loc[new_g][s] = S_G.first_loc[old_g][s]; S_G.first_loc[old_g][s] = FIX(0);
+      S_G.base_loc[new_g][s] = S_G.base_loc[old_g][s]; S_G.base_loc[old_g][s] = FIX(0);
+      S_G.next_loc[new_g][s] = S_G.next_loc[old_g][s]; S_G.next_loc[old_g][s] = FIX(0);
+      S_G.bytes_left[new_g][s] = S_G.bytes_left[old_g][s]; S_G.bytes_left[old_g][s] = 0;
+      S_G.bytes_of_space[new_g][s] = S_G.bytes_of_space[old_g][s]; S_G.bytes_of_space[old_g][s] = 0;
+      S_G.occupied_segments[new_g][s] = S_G.occupied_segments[old_g][s]; S_G.occupied_segments[old_g][s] = NULL;
+      for (si = S_G.occupied_segments[new_g][s]; si != NULL; si = si->next) {
+        si->generation = new_g;
+      }
+    }
+    S_G.guardians[new_g] = S_G.guardians[old_g]; S_G.guardians[old_g] = Snil;
+    S_G.locked_objects[new_g] = S_G.locked_objects[old_g]; S_G.locked_objects[old_g] = Snil;
+    S_G.unlocked_objects[new_g] = S_G.unlocked_objects[old_g]; S_G.unlocked_objects[old_g] = Snil;
+    S_G.buckets_of_generation[new_g] = S_G.buckets_of_generation[old_g]; S_G.buckets_of_generation[old_g] = NULL;
+    if (S_G.enable_object_counts) {
+      INT i; ptr ls;
+      for (i = 0; i < countof_types; i += 1) {
+        S_G.countof[new_g][i] = S_G.countof[old_g][i]; S_G.countof[old_g][i] = 0;
+        S_G.bytesof[new_g][i] = S_G.bytesof[old_g][i]; S_G.bytesof[old_g][i] = 0;
+      }
+      S_G.rtds_with_counts[new_g] = S_G.rtds_with_counts[old_g]; S_G.rtds_with_counts[old_g] = Snil;
+      for (ls = S_G.rtds_with_counts[new_g]; ls != Snil; ls = Scdr(ls)) {
+        ptr counts = RECORDDESCCOUNTS(Scar(ls));
+        RTDCOUNTSIT(counts, new_g) = RTDCOUNTSIT(counts, old_g); RTDCOUNTSIT(counts, old_g) = 0;
+      }
+      for (ls = S_G.rtds_with_counts[static_generation]; ls != Snil; ls = Scdr(ls)) {
+        ptr counts = RECORDDESCCOUNTS(Scar(ls));
+        RTDCOUNTSIT(counts, new_g) = RTDCOUNTSIT(counts, old_g); RTDCOUNTSIT(counts, old_g) = 0;
+      }
+    }
+#ifndef WIN32
+    S_child_processes[new_g] = S_child_processes[old_g];
+#endif
+
+    /* change old_g dirty bytes in static generation to new_g; splice list of old_g
+       seginfos onto front of new_g seginfos */
+    for (from_g = 1; from_g <= static_generation; INCRGEN(from_g)) {
+      for (to_g = 0; (from_g == static_generation) ? (to_g <= S_G.max_nonstatic_generation) : (to_g < from_g); to_g += 1) {
+        if ((si = DirtySegments(from_g, to_g)) != NULL) {
+          if (from_g == old_g) {
+            DirtySegments(from_g, to_g) = NULL;
+            DirtySegments(new_g, to_g) = si;
+            si->dirty_prev = &DirtySegments(new_g, to_g);
+          } else if (from_g == static_generation) {
+            if (to_g == old_g) {
+              DirtySegments(from_g, to_g) = NULL;
+              tail = DirtySegments(from_g, new_g);
+              DirtySegments(from_g, new_g) = si;
+              si->dirty_prev = &DirtySegments(from_g, new_g);
+              for (;;) {
+                INT d;
+                si->min_dirty_byte = new_g;
+                for (d = 0; d < cards_per_segment; d += 1) {
+                  if (si->dirty_bytes[d] == old_g) si->dirty_bytes[d] = new_g;
+                }
+                nextsi = si->dirty_next;
+                if (nextsi == NULL) break;
+                si = nextsi;
+              }
+              if (tail != NULL) tail->dirty_prev = &si->dirty_next;
+              si->dirty_next = tail;
+            } else {
+              do {
+                INT d;
+                for (d = 0; d < cards_per_segment; d += 1) {
+                  if (si->dirty_bytes[d] == old_g) si->dirty_bytes[d] = new_g;
+                }
+                si = si->dirty_next;
+              } while (si != NULL);
+            }
+          } else {
+            S_error_abort("S_do_gc(gc): unexpected nonempty dirty segment list");
+          }
+        }
+      }
+    }
+
+   /* tell profile_release_counters to scan only through new_g */
+    if (S_G.prcgeneration == old_g) S_G.prcgeneration = new_g;
+
+   /* finally reset max_nonstatic_generation */
+    S_G.min_free_gen = S_G.new_min_free_gen;
+    S_G.max_nonstatic_generation = new_g;
+  } else {
+    S_gc(tc, max_cg, min_tg, max_tg);
+  }
+
+ /* eagerly give collecting thread, the only one guaranteed to be
+    active, a fresh allocation area.  the other threads have to trap
+    to get_more_room if and when they awake and try to allocate */
+  S_reset_allocation_pointer(tc);
+
+  S_pants_down -= 1;
+
+  Sunlock_object(code);
+}
+
+
+void S_gc(ptr tc, IGEN max_cg, IGEN min_tg, IGEN max_tg) {
+  if (max_cg == 0 && min_tg == 1 && max_tg == 1 && S_G.locked_objects[0] == Snil)
+    S_gc_011(tc);
+  else if (max_tg == static_generation || S_G.enable_object_counts)
+    S_gc_oce(tc, max_cg, min_tg, max_tg);
+  else
+    S_gc_ocd(tc, max_cg, min_tg, max_tg);
+}

ta6ob/c/globals.h

@@ -0,0 +1,156 @@
+/* globals.h
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+/* globals that do NOT need to be preserved in a saved heap.
+ * they must be initialized each time the system is brought up. */
+
+/* gc.c */
+EXTERN IBOOL S_checkheap;
+EXTERN uptr S_checkheap_errors;
+#ifndef WIN32
+EXTERN ptr S_child_processes[static_generation+1];
+#endif /* WIN32 */
+
+/* scheme.c */
+EXTERN IBOOL S_boot_time;
+EXTERN IBOOL S_errors_to_console;
+EXTERN ptr S_threads;
+EXTERN uptr S_nthreads;
+EXTERN uptr S_pagesize;
+EXTERN void (*S_abnormal_exit_proc)();
+EXTERN char *Sschemeheapdirs;
+EXTERN char *Sdefaultheapdirs;
+#ifdef PTHREADS
+EXTERN s_thread_key_t S_tc_key;
+EXTERN scheme_mutex_t S_tc_mutex;
+EXTERN s_thread_cond_t S_collect_cond;
+EXTERN INT S_tc_mutex_depth;
+#endif
+
+/* segment.c */
+#ifdef segment_t2_bits
+#ifdef segment_t3_bits
+EXTERN t2table *S_segment_info[1<<segment_t3_bits];
+#else
+EXTERN t1table *S_segment_info[1<<segment_t2_bits];
+#endif
+#else
+EXTERN seginfo *S_segment_info[1<<segment_t1_bits];
+#endif
+
+EXTERN chunkinfo *S_chunks_full;
+EXTERN chunkinfo *S_chunks[PARTIAL_CHUNK_POOLS+1];
+
+/* schsig.c */
+EXTERN IBOOL S_pants_down;
+
+/* foreign.c */
+#ifdef LOAD_SHARED_OBJECT
+EXTERN ptr S_foreign_dynamic;
+#endif
+
+/* globals that do need to be preserved in a saved heap */
+EXTERN struct S_G_struct {
+  /* scheme.c */
+    double thread_context[size_tc / sizeof(double)];
+    ptr active_threads_id;
+    ptr error_invoke_code_object;
+    ptr invoke_code_object;
+    ptr dummy_code_object;
+    ptr heap_reserve_ratio_id;
+    IBOOL retain_static_relocation;
+    IBOOL enable_object_counts;
+    ptr scheme_version_id;
+    ptr make_load_binary_id;
+    ptr load_binary;
+    ptr profile_counters;
+
+  /* foreign.c */
+    ptr foreign_static;
+    ptr foreign_names;
+
+  /* thread.c */
+    ptr threadno;
+
+  /* segment.c */
+    seginfo *occupied_segments[static_generation+1][max_real_space+1];
+    uptr number_of_nonstatic_segments;
+    uptr number_of_empty_segments;
+
+  /* alloc.c */
+    ptr *protected[max_protected];
+    uptr protect_next;
+    ptr first_loc[static_generation+1][max_real_space+1];
+    ptr base_loc[static_generation+1][max_real_space+1];
+    ptr next_loc[static_generation+1][max_real_space+1];
+    iptr bytes_left[static_generation+1][max_real_space+1];
+    uptr bytes_of_space[static_generation+1][max_real_space+1];
+    uptr bytes_of_generation[static_generation+1];
+    uptr g0_bytes_after_last_gc;
+    uptr collect_trip_bytes;
+    ptr nonprocedure_code;
+    ptr null_string;
+    ptr null_vector;
+    ptr null_fxvector;
+    ptr null_bytevector;
+    seginfo *dirty_segments[DIRTY_SEGMENT_LISTS];
+
+  /* schsig.c */
+    ptr error_id;
+    ptr nuate_id;
+    ptr null_continuation_id;
+    ptr collect_request_pending_id;
+
+  /* gc.c */
+    ptr guardians[static_generation+1];
+    ptr locked_objects[static_generation+1];
+    ptr unlocked_objects[static_generation+1];
+    IGEN min_free_gen;
+    IGEN new_min_free_gen;
+    IGEN max_nonstatic_generation;
+    IGEN new_max_nonstatic_generation;
+    uptr countof[static_generation+1][countof_types];
+    uptr bytesof[static_generation+1][countof_types];
+    uptr gctimestamp[static_generation+1];
+    ptr rtds_with_counts[static_generation+1];
+    uptr countof_size[countof_types];
+    ptr static_id;
+    ptr countof_names;
+    IGEN prcgeneration;
+
+  /* intern.c */
+    iptr *oblist_length_pointer;
+    iptr oblist_length;
+    iptr oblist_count;
+    bucket **oblist;
+    bucket_list *buckets_of_generation[static_generation];
+
+  /* prim.c */
+    ptr library_entry_vector;
+    ptr c_entry_vector;
+
+  /* fasl.c */
+    ptr base_rtd;
+    ptr rtd_key;
+    ptr eq_symbol;
+    ptr eq_ht_rtd;
+    ptr symbol_symbol;
+    ptr symbol_ht_rtd;
+    ptr eqp;
+    ptr eqvp;
+    ptr equalp;
+    ptr symboleqp;
+} S_G;

ta6ob/c/i3le.c

@@ -0,0 +1,26 @@
+/* i3le.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+#include <sys/types.h>
+#include <sys/mman.h>
+
+#ifdef FLUSHCACHE
+oops, no S_flushcache_max_gap or S_doflush
+#endif /* FLUSHCACHE */
+
+void S_machine_init(void) {}

ta6ob/c/intern.c

@@ -0,0 +1,389 @@
+/* intern.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+/* locally defined functions */
+static void oblist_insert(ptr sym, iptr idx, IGEN g);
+static iptr hash(const unsigned char *s, iptr n);
+static iptr hash_sc(const string_char *s, iptr n);
+static iptr hash_uname(const string_char *s, iptr n);
+static ptr mkstring(const string_char *s, iptr n);
+
+/* list of some primes to use for oblist sizes */
+#if (ptr_bits == 32)
+static iptr oblist_lengths[] = {
+  1031,
+  2053,
+  4099,
+  8209,
+  16411,
+  32771,
+  65537,
+  131101,
+  262147,
+  524309,
+  1048583,
+  2097169,
+  4194319,
+  8388617,
+  16777259,
+  33554467,
+  67108879,
+  134217757,
+  268435459,
+  536870923,
+  1073741827,
+  0};
+#endif
+#if (ptr_bits == 64)
+static iptr oblist_lengths[] = {
+  1031,
+  2053,
+  4099,
+  8209,
+  16411,
+  32771,
+  65537,
+  131101,
+  262147,
+  524309,
+  1048583,
+  2097169,
+  4194319,
+  8388617,
+  16777259,
+  33554467,
+  67108879,
+  134217757,
+  268435459,
+  536870923,
+  1073741827,
+  2147483659,
+  4294967311,
+  8589934609,
+  17179869209,
+  34359738421,
+  68719476767,
+  137438953481,
+  274877906951,
+  549755813911,
+  1099511627791,
+  2199023255579,
+  4398046511119,
+  8796093022237,
+  17592186044423,
+  35184372088891,
+  70368744177679,
+  140737488355333,
+  281474976710677,
+  562949953421381,
+  1125899906842679,
+  2251799813685269,
+  4503599627370517,
+  9007199254740997,
+  18014398509482143,
+  36028797018963971,
+  72057594037928017,
+  144115188075855881,
+  288230376151711813,
+  576460752303423619,
+  1152921504606847009,
+  2305843009213693967,
+  4611686018427388039,
+  0};
+#endif
+
+void S_intern_init(void) {
+    IGEN g;
+
+    if (!S_boot_time) return;
+
+    S_G.oblist_length_pointer = &oblist_lengths[3];
+    S_G.oblist_length = *S_G.oblist_length_pointer;
+    S_G.oblist_count = 0;
+    S_G.oblist = S_getmem(S_G.oblist_length * sizeof(bucket *), 1);
+    for (g = 0; g < static_generation; g += 1) S_G.buckets_of_generation[g] = NULL;
+}
+
+static void oblist_insert(ptr sym, iptr idx, IGEN g) {
+  bucket *b, *oldb, **pb;
+
+  find_room(g == 0 ? space_new : space_data, g, typemod, sizeof(bucket), b);
+  b->sym = sym;
+  if (g == 0) {
+    b->next = S_G.oblist[idx];
+    S_G.oblist[idx] = b;
+  } else {
+    for (pb = &S_G.oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(oldb)) < g; pb = &oldb->next);
+    b->next = oldb;
+    *pb = b;
+  }
+
+  if (g != static_generation) {
+    bucket_list *bl;
+    find_room(g == 0 ? space_new : space_data, g, typemod, sizeof(bucket_list), bl);
+    bl->car = b;
+    bl->cdr = S_G.buckets_of_generation[g];
+    S_G.buckets_of_generation[g] = bl;
+  }
+
+  S_G.oblist_count += 1;
+}
+
+void S_resize_oblist(void) {
+  bucket **new_oblist, *b, *oldb, **pb, *bnext;
+  iptr *new_oblist_length_pointer, new_oblist_length, i, idx;
+  ptr sym;
+  IGEN g;
+
+  new_oblist_length_pointer = S_G.oblist_length_pointer;
+
+  if (S_G.oblist_count < S_G.oblist_length) {
+    while (new_oblist_length_pointer != &oblist_lengths[0] && *(new_oblist_length_pointer - 1) >= S_G.oblist_count) {
+      new_oblist_length_pointer -= 1;
+    }
+  } else if (S_G.oblist_count > S_G.oblist_length) {
+    while (*(new_oblist_length_pointer + 1) != 0 && *(new_oblist_length_pointer + 1) <= S_G.oblist_count) {
+      new_oblist_length_pointer += 1;
+    }
+  }
+
+  if (new_oblist_length_pointer == S_G.oblist_length_pointer) return;
+
+  new_oblist_length = *new_oblist_length_pointer;
+  new_oblist = S_getmem(new_oblist_length * sizeof(bucket *), 1);
+
+  for (i = 0; i < S_G.oblist_length; i += 1) {
+    for (b = S_G.oblist[i]; b != NULL; b = bnext) {
+      bnext = b->next;
+      sym = b->sym;
+      idx = UNFIX(SYMHASH(sym)) % new_oblist_length;
+      g = GENERATION(sym);
+
+      for (pb = &new_oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(oldb)) < g; pb = &oldb->next);
+      b->next = oldb;
+      *pb = b;
+    }
+  }
+
+  S_freemem(S_G.oblist, S_G.oblist_length * sizeof(bucket *));
+  S_G.bytesof[static_generation][countof_oblist] += (new_oblist_length - S_G.oblist_length) * sizeof(bucket *);
+
+  S_G.oblist_length_pointer = new_oblist_length_pointer;
+  S_G.oblist_length = new_oblist_length;
+  S_G.oblist = new_oblist;
+}
+
+/* hash function: multiplier weights each character, h = n factors in the length */
+#define multiplier 3
+
+static iptr hash(const unsigned char *s, iptr n) {
+  iptr h = n + 401887359;
+  while (n--) h = h * multiplier + *s++;
+  return h & most_positive_fixnum;
+}
+
+static iptr hash_sc(const string_char *s, iptr n) {
+  iptr h = n + 401887359;
+  while (n--) h = h * multiplier + Schar_value(*s++);
+  return h & most_positive_fixnum;
+}
+
+static iptr hash_uname(const string_char *s, iptr n) {
+  /* attempting to get dissimilar hash codes for gensyms created in the same session */
+  iptr i = n, h = 0; iptr pos = 1; int d, c;
+
+  while (i-- > 0) {
+    if ((c = Schar_value(s[i])) == '-') {
+      if (pos <= 10) break;
+      return (h + 523658599) & most_positive_fixnum;
+    }
+    d = c - '0';
+    if (d < 0 || d > 9) break;
+    h += d * pos;
+    pos *= 10;
+  }
+
+  return hash_sc(s, n);
+}
+
+static ptr mkstring(const string_char *s, iptr n) {
+  iptr i;
+  ptr str = S_string(NULL, n);
+  for (i = 0; i != n; i += 1) STRIT(str, i) = s[i];
+  return str;
+}
+
+/* handles single-byte characters, implicit length */
+ptr S_intern(const unsigned char *s) {
+  iptr n = strlen((const char *)s);
+  iptr hc = hash(s, n);
+  iptr idx = hc % S_G.oblist_length;
+  ptr sym;
+  bucket *b;
+
+  tc_mutex_acquire()
+
+  b = S_G.oblist[idx];
+  while (b != NULL) {
+    sym = b->sym;
+    if (!GENSYMP(sym)) {
+       ptr str = SYMNAME(sym);
+       if (Sstring_length(str) == n) {
+          iptr i;
+          for (i = 0; ; i += 1) {
+            if (i == n) {
+               tc_mutex_release()
+               return sym;
+            }
+            if (Sstring_ref(str, i) != s[i]) break;
+          }
+       }
+    }
+    b = b->next;
+  }
+
+  sym = S_symbol(S_string((const char *)s, n));
+  INITSYMHASH(sym) = FIX(hc);
+  oblist_insert(sym, idx, 0);
+
+  tc_mutex_release()
+  return sym;
+}
+
+/* handles string_chars, explicit length */
+ptr S_intern_sc(const string_char *name, iptr n, ptr name_str) {
+  iptr hc = hash_sc(name, n);
+  iptr idx = hc % S_G.oblist_length;
+  ptr sym;
+  bucket *b;
+
+  tc_mutex_acquire()
+
+  b = S_G.oblist[idx];
+  while (b != NULL) {
+    sym = b->sym;
+    if (!GENSYMP(sym)) {
+       ptr str = SYMNAME(sym);
+       if (Sstring_length(str) == n) {
+          iptr i;
+          for (i = 0; ; i += 1) {
+            if (i == n) {
+               tc_mutex_release()
+               return sym;
+            }
+            if (STRIT(str, i) != name[i]) break;
+          }
+       }
+    }
+    b = b->next;
+  }
+
+  /* if (name_str == Sfalse) */ name_str = mkstring(name, n);
+  sym = S_symbol(name_str);
+  INITSYMHASH(sym) = FIX(hc);
+  oblist_insert(sym, idx, 0);
+
+  tc_mutex_release()
+  return sym;
+}
+
+ptr S_intern3(const string_char *pname, iptr plen, const string_char *uname, iptr ulen, ptr pname_str, ptr uname_str) {
+  iptr hc = hash_uname(uname, ulen);
+  iptr idx = hc % S_G.oblist_length;
+  ptr sym;
+  bucket *b;
+
+  tc_mutex_acquire()
+
+  b = S_G.oblist[idx];
+  while (b != NULL) {
+    sym = b->sym;
+    if (GENSYMP(sym)) {
+       ptr str = Scar(SYMNAME(sym));
+       if (Sstring_length(str) == ulen) {
+          iptr i;
+          for (i = 0; ; i += 1) {
+            if (i == ulen) {
+               tc_mutex_release()
+               return sym;
+            }
+            if (STRIT(str, i) != uname[i]) break;
+          }
+       }
+    }
+    b = b->next;
+  }
+
+  if (pname_str == Sfalse) pname_str = mkstring(pname, plen);
+  if (uname_str == Sfalse) uname_str = mkstring(uname, ulen);
+  sym = S_symbol(Scons(uname_str, pname_str));
+  INITSYMHASH(sym) = FIX(hc);
+  oblist_insert(sym, idx, 0);
+
+  tc_mutex_release()
+  return sym;
+}
+
+void S_intern_gensym(ptr sym) {
+  ptr uname_str = Scar(SYMNAME(sym));
+  const string_char *uname = &STRIT(uname_str, 0);
+  iptr ulen = Sstring_length(uname_str);
+  iptr hc = hash_uname(uname, ulen);
+  iptr idx = hc % S_G.oblist_length;
+  bucket *b;
+
+  tc_mutex_acquire()
+
+  b = S_G.oblist[idx];
+  while (b != NULL) {
+    ptr x = b->sym;
+    if (GENSYMP(x)) {
+       ptr str = Scar(SYMNAME(x));
+       if (Sstring_length(str) == ulen) {
+          iptr i;
+          for (i = 0; ; i += 1) {
+            if (i == ulen) {
+               tc_mutex_release()
+               S_error1("intern-gensym", "unique name ~s already interned", uname_str);
+            }
+            if (Sstring_ref(str, i) != uname[i]) break;
+          }
+       }
+    }
+    b = b->next;
+  }
+
+  INITSYMHASH(sym) = FIX(hc);
+  oblist_insert(sym, idx, GENERATION(sym));
+
+  tc_mutex_release()
+}
+
+/* retrofit existing symbols once nonprocedure_code is available */
+void S_retrofit_nonprocedure_code(void) {
+  ptr npc, sym, val; bucket_list *bl;
+
+  npc = S_G.nonprocedure_code;
+
+  /* assuming this happens early, before collector has been called, so need look only for generation 0 symbols */
+  for (bl = S_G.buckets_of_generation[0]; bl != NULL; bl = bl->cdr) {
+    sym = bl->car->sym;
+    val = SYMVAL(sym);
+    SETSYMCODE(sym, Sprocedurep(val) ? CLOSCODE(val) : npc);
+  }
+}

ta6ob/c/io.c

@@ -0,0 +1,277 @@
+/* io.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <limits.h>
+#ifdef WIN32
+#include <io.h>
+#include <shlobj.h>
+#pragma comment(lib, "shell32.lib")
+#else /* WIN32 */
+#include <sys/file.h>
+#include <dirent.h>
+#include <pwd.h>
+#endif /* WIN32 */
+
+/* locally defined functions */
+#ifdef WIN32
+static ptr s_wstring_to_bytevector(const wchar_t *s);
+#else
+static ptr s_string_to_bytevector(const char *s);
+#endif
+
+/* raises an exception if insufficient space cannot be malloc'd.
+   otherwise returns a freshly allocated version of inpath with ~ (home directory)
+   prefix expanded, if possible */
+char *S_malloc_pathname(const char *inpath) {
+  char *outpath; const char *ip;
+
+#ifdef WIN32
+  if (*inpath == '~' && (*(ip = inpath + 1) == 0 || DIRMARKERP(*ip))) {
+    wchar_t* homew;
+    if (SUCCEEDED(SHGetKnownFolderPath(&FOLDERID_Profile, 0, NULL, &homew))) {
+      char *home = Swide_to_utf8(homew);
+      CoTaskMemFree(homew);
+      if (NULL != home) {
+        size_t n1, n2;
+        n1 = strlen(home);
+        n2 = strlen(ip) + 1;
+        if ((outpath = malloc(n1 + n2)) == NULL) {
+          free(home);
+          S_error("expand_pathname", "malloc failed");
+        }
+        memcpy(outpath, home, n1);
+        memcpy(outpath + n1, ip, n2);
+        free(home);
+        return outpath;
+      }
+    }
+  }
+#else /* WIN32 */
+  if (*inpath == '~') {
+    const char *dir; size_t n1, n2; struct passwd *pwent;
+    if (*(ip = inpath + 1) == 0 || DIRMARKERP(*ip)) {
+      if ((dir = getenv("HOME")) == NULL)
+        if ((pwent = getpwuid(getuid())) != NULL)
+          dir = pwent->pw_dir;
+    } else {
+      char *userbuf; const char *user_start = ip;
+      do { ip += 1; } while (*ip != 0 && !DIRMARKERP(*ip));
+      if ((userbuf = malloc(ip - user_start + 1)) == NULL) S_error("expand_pathname", "malloc failed");
+      memcpy(userbuf, user_start, ip - user_start);
+      userbuf[ip - user_start] = 0;
+      dir = (pwent = getpwnam(userbuf)) != NULL ? pwent->pw_dir : NULL;
+      free(userbuf);
+    }
+    if (dir != NULL) {
+      n1 = strlen(dir);
+      n2 = strlen(ip) + 1;
+      if ((outpath = malloc(n1 + n2)) == NULL) S_error("expand_pathname", "malloc failed");
+      memcpy(outpath, dir, n1);
+      memcpy(outpath + n1, ip, n2);
+      return outpath;
+    }
+  }
+#endif /* WIN32 */
+
+  /* if no ~ or tilde dir can't be found, copy inpath */
+  {
+    size_t n = strlen(inpath) + 1;
+    if ((outpath = (char *)malloc(n)) == NULL) S_error("expand_pathname", "malloc failed");
+    memcpy(outpath, inpath, n);
+    return outpath;
+  }
+}
+
+#ifdef WIN32
+wchar_t *S_malloc_wide_pathname(const char *inpath) {
+  char *path = S_malloc_pathname(inpath);
+  wchar_t *wpath = Sutf8_to_wide(path);
+  free(path);
+  return wpath;
+}
+#endif
+
+IBOOL S_fixedpathp(const char *inpath) {
+  char c; IBOOL res; char *path;
+
+  path = S_malloc_pathname(inpath);
+  res = (c = *path) == 0
+        || DIRMARKERP(c)
+#ifdef WIN32
+        || ((*(path + 1) == ':') && (c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'))
+#endif
+        || ((c == '.')
+            && ((c = *(path + 1)) == 0
+                || DIRMARKERP(c)
+                || (c == '.' && ((c = *(path + 2)) == 0 || DIRMARKERP(c)))));
+  free(path);
+  return res;
+}
+
+IBOOL S_file_existsp(const char *inpath, IBOOL followp) {
+#ifdef WIN32
+  wchar_t *wpath; IBOOL res;
+  WIN32_FILE_ATTRIBUTE_DATA filedata;
+  
+  if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
+    return 0;
+  } else {
+    res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata);
+    free(wpath);
+    return res;
+  }
+#else /* WIN32 */
+  struct STATBUF statbuf; char *path; IBOOL res;
+
+  path = S_malloc_pathname(inpath);
+  res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0;
+  free(path);
+  return res;
+#endif /* WIN32 */
+}
+
+IBOOL S_file_regularp(const char *inpath, IBOOL followp) {
+#ifdef WIN32
+  wchar_t *wpath; IBOOL res;
+  WIN32_FILE_ATTRIBUTE_DATA filedata;
+  
+  if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
+    return 0;
+  } else {
+    res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)
+          && (filedata.dwFileAttributes & (FILE_ATTRIBUTE_DEVICE | FILE_ATTRIBUTE_DIRECTORY | FILE_ATTRIBUTE_REPARSE_POINT)) == 0;
+    free(wpath);
+    return res;
+  }
+#else /* WIN32 */
+  struct STATBUF statbuf; char *path; IBOOL res;
+
+  path = S_malloc_pathname(inpath);
+  res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0
+        && (statbuf.st_mode & S_IFMT) == S_IFREG;
+  free(path);
+  return res;
+#endif /* WIN32 */
+}
+
+IBOOL S_file_directoryp(const char *inpath, IBOOL followp) {
+#ifdef WIN32
+  wchar_t *wpath; IBOOL res;
+  WIN32_FILE_ATTRIBUTE_DATA filedata;
+  
+  if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
+    return 0;
+  } else {
+    res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)
+          && filedata.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY;
+    free(wpath);
+    return res;
+  }
+#else /* WIN32 */
+  struct STATBUF statbuf; char *path; IBOOL res;
+
+  path = S_malloc_pathname(inpath);
+  res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0
+        && (statbuf.st_mode & S_IFMT) == S_IFDIR;
+  free(path);
+  return res;
+#endif /* WIN32 */
+}
+
+IBOOL S_file_symbolic_linkp(const char *inpath) {
+#ifdef WIN32
+  wchar_t *wpath; IBOOL res;
+  WIN32_FILE_ATTRIBUTE_DATA filedata;
+  
+  if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
+    return 0;
+  } else {
+    res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)
+          && filedata.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT;
+    free(wpath);
+    return res;
+  }
+#else /* WIN32 */
+  struct STATBUF statbuf; char *path; IBOOL res;
+
+  path = S_malloc_pathname(inpath);
+  res = LSTAT(path, &statbuf) == 0 && (statbuf.st_mode & S_IFMT) == S_IFLNK;
+  free(path);
+  return res;
+#endif /* WIN32 */
+}
+
+#ifdef WIN32
+static ptr s_wstring_to_bytevector(const wchar_t *s) {
+  iptr n; ptr bv;
+  if ((n = wcslen(s)) == 0) return S_G.null_bytevector;
+  n *= sizeof(wchar_t);
+  bv = S_bytevector(n);
+  memcpy(&BVIT(bv,0), s, n);
+  return bv;
+}
+
+ptr S_find_files(const char *wildpath) {
+  wchar_t *wwildpath;
+  intptr_t handle;
+  struct _wfinddata_t fileinfo;
+
+  if ((wwildpath = S_malloc_wide_pathname(wildpath)) == NULL)
+    return S_LastErrorString();
+
+  if ((handle = _wfindfirst(wwildpath, &fileinfo)) == (intptr_t)-1) {
+    free(wwildpath);
+    return S_strerror(errno);
+  } else {
+    ptr ls = Snil;
+    do {
+      ls = Scons(s_wstring_to_bytevector(fileinfo.name), ls);
+    } while (_wfindnext(handle, &fileinfo) == 0);
+    _findclose(handle);
+    free(wwildpath);
+    return ls;
+  }
+}
+#else /* WIN32 */
+static ptr s_string_to_bytevector(const char *s) {
+  iptr n; ptr bv;
+  if ((n = strlen(s)) == 0) return S_G.null_bytevector;
+  bv = S_bytevector(n);
+  memcpy(&BVIT(bv,0), s, n);
+  return bv;
+}
+
+ptr S_directory_list(const char *inpath) {
+  char *path; DIR *dirp;
+
+  path = S_malloc_pathname(inpath);
+  if ((dirp = opendir(path)) == (DIR *)0) {
+    free(path);
+    return S_strerror(errno);
+  } else {
+    struct dirent *dep; ptr ls = Snil;
+
+    while ((dep = readdir(dirp)) != (struct dirent *)0)
+      ls = Scons(s_string_to_bytevector(dep->d_name), ls);
+    closedir(dirp);
+    free(path);
+    return ls;
+  }
+}
+#endif /* WIN32 */

ta6ob/c/itest.c

@@ -0,0 +1,247 @@
+/* itest.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#define r_EOF 0
+#define r_LPAREN 1
+#define r_RPAREN 2
+#define r_CONST 3
+
+static INT digit_value(ICHAR c, INT r) {
+  switch (r) {
+    case 2:
+      if ('0' <= c && c <= '1') return c - '0';
+      break;
+    case 8:
+      if ('0' <= c && c <= '8') return c - '0';
+      break;
+    case 10:
+      if ('0' <= c && c <= '9') return c - '0';
+      break;
+    case 16:
+      if ('0' <= c && c <= '9') return c - '0';
+      if ('a' <= c && c <= 'f') return c - 'a';
+      if ('A' <= c && c <= 'F') return c - 'A';
+    default:
+      break;
+  }
+  return -1;
+}
+
+static INT read_int(ptr *v, ptr n, INT r, IBOOL sign) {
+  INT i, c;
+
+  for (;;) {
+    if ((i = digit_value((c = getchar()), r)) == -1) {
+      ungetc(c, stdin);
+      break;
+    }
+    n = S_add(S_mul(n, FIX(r)), FIX(i));
+  }
+  *v = sign ? S_sub(FIX(0), n) : n;
+  return r_CONST;
+}
+
+static INT read_token(ptr *v) {
+  ICHAR c = getchar();
+  switch (c) {
+    case SEOF: return r_EOF;
+    case '\n':
+    case ' ': return read_token(v);
+    case ';':
+      for (;;) {
+        switch (getchar()) {
+          case SEOF:
+           return r_EOF;
+          case '\n':
+           return read_token(v);
+          default:
+           break;
+        }
+      }
+    case '(': return r_LPAREN;
+    case ')': return r_RPAREN;
+    case '#': {
+      ICHAR c = getchar();
+      INT r = 10;
+      switch (c) {
+        case 'x':
+          r = 16;
+        case 'o':
+          if (r == 0) r = 8;
+        case 'b':
+          if (r == 10) r = 2;
+        case 'd': {
+          INT i;
+          IBOOL sign = 0;
+          c = getchar();
+          if (c == '+')
+            c = getchar();
+          else if (c == '-') {
+            sign = 1;
+            c = getchar();
+          }
+
+          if ((i = digit_value(c, r)) != -1)
+            return read_int(v, FIX(i), r, sign);
+        }
+        default:
+          printf("malformed hash prefix ignored\n");
+          return read_token(v);
+      }
+    }
+    case '+':
+    case '-': {
+      INT i, c2;
+      if ((i = digit_value((c2 = getchar()), 10)) == -1) {
+        ungetc(c2, stdin);
+      } else {
+        return read_int(v, FIX(i), 10, c == '-');
+      }
+    }
+    case '*':
+    case '/':
+    case 'q':
+    case 'r':
+    case 'g':
+    case '=':
+    case '<':
+    case 'f':
+    case 'c':
+    case 'd':
+      *v = Schar(c);
+      return r_CONST;
+    default: {
+      INT i;
+      if ((i = digit_value(c, 10)) != -1)
+        return read_int(v, FIX(i), 10, 0);
+      }
+      break;
+  }
+  printf("invalid character %d ignored\n", c);
+  return read_token(v);
+}
+
+static ptr readx(INT t, ptr v);
+
+static ptr read_list(void) {
+  INT t; ptr v, x;
+
+  t = read_token(&v);
+  if (t == r_RPAREN) return Snil;
+  x = readx(t, v);
+  return Scons(x, read_list());
+}
+
+static ptr readx(INT t, ptr v) {
+
+  switch (t) {
+    case r_EOF:
+      printf("unexpected EOF\n");
+      exit(1);
+    case r_LPAREN: return read_list();
+    case r_RPAREN:
+      printf("unexpected right paren ignored\n");
+      t = read_token(&v);
+      return readx(t, v);
+    case r_CONST: return v;
+    default:
+      printf("invalid token %d\n", t);
+      exit(1);
+  }
+}
+
+static ptr read_top(void) {
+  INT t; ptr v;
+
+  t = read_token(&v);
+  switch (t) {
+    case r_EOF: return Seof_object;
+    case r_RPAREN: return read_top();
+    default: return readx(t, v);
+  }
+}
+
+static ptr eval(ptr x);
+
+#define First(x) eval(Scar(Scdr(x)))
+#define Second(x) eval(Scar(Scdr(Scdr(x))))
+
+static ptr eval(ptr x) {
+  if (Spairp(x)) {
+    switch (Schar_value(Scar(x))) {
+      case '+': return S_add(First(x), Second(x));
+      case '-': return S_sub(First(x), Second(x));
+      case '*': return S_mul(First(x), Second(x));
+      case '/': return S_div(First(x), Second(x));
+      case 'q': return S_trunc(First(x), Second(x));
+      case 'r': return S_rem(First(x), Second(x));
+      case 'g': return S_gcd(First(x), Second(x));
+      case '=': {
+        ptr x1 = First(x), x2 = Second(x);
+        if (Sfixnump(x1) && Sfixnump(x2))
+          return Sboolean(x1 == x2);
+        else if (Sbignump(x1) && Sbignump(x2))
+          return Sboolean(S_big_eq(x1, x2));
+        else return Sfalse;
+      }
+      case '<': {
+        ptr x1 = First(x), x2 = Second(x);
+        if (Sfixnump(x1))
+          if (Sfixnump(x2))
+            return Sboolean(x1 < x2);
+          else
+            return Sboolean(!BIGSIGN(x2));
+        else
+          if (Sfixnump(x2))
+            return Sboolean(BIGSIGN(x1));
+          else
+            return Sboolean(S_big_lt(x1, x2));
+      }
+      case 'f': return Sflonum(S_floatify(First(x)));
+      case 'c':
+        S_gc(get_thread_context(), UNFIX(First(x)),UNFIX(Second(x)));
+        return Svoid;
+      case 'd': return S_decode_float(Sflonum_value(First(x)));
+      default:
+        S_prin1(x);
+        putchar('\n');
+        printf("unrecognized operator, returning zero\n");
+        return FIX(0);
+    }
+  } else
+    return x;
+}
+
+#undef PROMPT
+#undef NOISY
+static void bignum_test(void) {
+  ptr x;
+  for (;;) {
+#ifdef PROMPT
+    putchar('*');
+    putchar(' ');
+#endif
+    x = read_top();
+    if (x == Seof_object) { putchar('\n'); exit(0); }
+#ifdef NOISY
+    S_prin1(x);
+    putchar('\n');
+#endif
+    x = eval(x);
+    S_prin1(x);
+    putchar('\n');
+  }
+}

ta6ob/c/main.c

@@ -0,0 +1,376 @@
+/* main.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include "scheme.h"
+#include "config.h"
+
+/****
+  CUSTOM_INIT may be defined as a function with the signature shown to
+  perform boot-time initialization, e.g., registering foreign symbols.
+****/
+#ifndef CUSTOM_INIT
+#define CUSTOM_INIT ((void (*)(void))0)
+#endif /* CUSTOM_INIT */
+
+/****
+  ABNORMAL_EXIT may be defined as a function with the signature shown to
+  take some action, such as printing a special error message or performing
+  a nonlocal exit with longjmp, when the Scheme system exits abnormally,
+  i.e., when an unrecoverable error occurs.  If left null, the default
+  is to call exit(1).
+****/
+#ifndef ABNORMAL_EXIT
+#define ABNORMAL_EXIT ((void (*)(void))0)
+#endif /* ABNORMAL_EXIT */
+
+#ifndef SCHEME_SCRIPT
+#define SCHEME_SCRIPT "scheme-script"
+#endif
+
+static const char *path_last(const char *p) {
+  const char *s;
+#ifdef WIN32
+  char c;
+  if ((c = *p) >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
+    if (*(p + 1) == ':')
+      p += 2;
+
+  for (s = p; *s != 0; s += 1)
+    if ((c = *s) == '/' || c == '\\') p = ++s;
+#else /* WIN32 */
+  for (s = p; *s != 0; s += 1) if (*s == '/') p = ++s;
+#endif /* WIN32 */
+  return p;
+}
+
+#if defined(WIN32) && !defined(__MINGW32__)
+#define GETENV Sgetenv
+#define GETENV_FREE free
+int wmain(int argc, wchar_t* wargv[], wchar_t* wenvp[]) {
+  const char** argv = (char**)malloc((argc + 1) * sizeof(char*));
+  int i;
+  for (i = 0; i < argc; i++) {
+    wchar_t* warg = wargv[i];
+    if (NULL == (argv[i] = Swide_to_utf8(warg))) {
+      fprintf_s(stderr, "Invalid argument: %S\n", warg);
+      exit(1);
+    }
+  }
+  argv[argc] = NULL;
+#else /* WIN32 */
+#define GETENV getenv
+#define GETENV_FREE (void)
+int main(int argc, const char *argv[]) {
+#endif /* WIN32 */
+  int n, new_argc = 1;
+#ifdef SAVEDHEAPS
+  int compact = 1, savefile_level = 0;
+  const char *savefile = (char *)0;
+#endif /* SAVEDHEAPS */
+  const char *execpath = argv[0];
+  const char *scriptfile = (char *)0;
+  const char *programfile = (char *)0;
+  const char *libdirs = (char *)0;
+  const char *libexts = (char *)0;
+  int status;
+  const char *arg;
+  int quiet = 0;
+  int eoc = 0;
+  int optlevel = 0;
+  int debug_on_exception = 0;
+  int import_notify = 0;
+  int compile_imported_libraries = 0;
+#ifdef FEATURE_EXPEDITOR
+  int expeditor_enable = 1;
+  const char *expeditor_history_file = "";  /* use "" for default location */
+#endif /* FEATURE_EXPEDITOR */
+
+  if (strcmp(Skernel_version(), VERSION) != 0) {
+    (void) fprintf(stderr, "unexpected shared library version %s for %s version %s\n", Skernel_version(), execpath, VERSION);
+    exit(1);
+  }
+
+  Sscheme_init(ABNORMAL_EXIT);
+
+  if (strcmp(path_last(execpath), SCHEME_SCRIPT) == 0) {
+    if (argc < 2) {
+      (void) fprintf(stderr,"%s requires program-path argument\n", execpath);
+      exit(1);
+    }
+    argv[0] = programfile = argv[1];
+    n = 1;
+    while (++n < argc) argv[new_argc++] = argv[n];
+  } else {
+   /* process command-line arguments, registering boot and heap files */
+    for (n = 1; n < argc; n += 1) {
+      arg = argv[n];
+      if (strcmp(arg,"--") == 0) {
+        while (++n < argc) argv[new_argc++] = argv[n];
+      } else if (strcmp(arg,"-b") == 0 || strcmp(arg,"--boot") == 0) {
+        if (++n == argc) {
+          (void) fprintf(stderr,"%s requires argument\n", arg);
+          exit(1);
+        }
+        Sregister_boot_file(argv[n]);
+      } else if (strcmp(arg,"--eedisable") == 0) {
+  #ifdef FEATURE_EXPEDITOR
+        expeditor_enable = 0;
+  #endif /* FEATURE_EXPEDITOR */
+      } else if (strcmp(arg,"--eehistory") == 0) {
+        if (++n == argc) {
+          (void) fprintf(stderr,"%s requires argument\n", arg);
+          exit(1);
+        }
+  #ifdef FEATURE_EXPEDITOR
+        if (strcmp(argv[n], "off") == 0)
+          expeditor_history_file = (char *)0;
+        else
+          expeditor_history_file = argv[n];
+  #endif /* FEATURE_EXPEDITOR */
+      } else if (strcmp(arg,"-q") == 0 || strcmp(arg,"--quiet") == 0) {
+        quiet = 1;
+      } else if (strcmp(arg,"--retain-static-relocation") == 0) {
+        Sretain_static_relocation();
+      } else if (strcmp(arg,"--enable-object-counts") == 0) {
+        eoc = 1;
+#ifdef SAVEDHEAPS
+      } else if (strcmp(arg,"-c") == 0 || strcmp(arg,"--compact") == 0) {
+        compact = !compact;
+      } else if (strcmp(arg,"-h") == 0 || strcmp(arg,"--heap") == 0) {
+        if (++n == argc) {
+          (void) fprintf(stderr,"%s requires argument\n", arg);
+          exit(1);
+        }
+        Sregister_heap_file(argv[n]);
+      } else if (strncmp(arg,"-s",2) == 0 &&
+                 (savefile_level = -2,
+                  *(arg+2) == 0 ||
+                  *(arg+3) == 0 &&
+                  ((savefile_level = *(arg+2) - '+' - 1) == -1 ||
+                    (savefile_level = *(arg+2) - '0') >= 0 &&
+                     savefile_level <= 9)) ||
+                 strncmp(arg,"--saveheap",10) == 0 &&
+                 (savefile_level = -2,
+                  *(arg+10) == 0 ||
+                  *(arg+11) == 0 &&
+                  ((savefile_level = *(arg+2) - '+' - 1) == -1 ||
+                    (savefile_level = *(arg+10) - '0') >= 0 &&
+                     savefile_level <= 9))) {
+        if (++n == argc) {
+          (void) fprintf(stderr,"%s requires argument\n", arg);
+          exit(1);
+        }
+        savefile = argv[n];
+#else /* SAVEDHEAPS */
+      } else if (strcmp(arg,"-c") == 0 || strcmp(arg,"--compact") == 0) {
+        fprintf(stderr, "-c and --compact options are not presently supported\n");
+        exit(1);
+      } else if (strcmp(arg,"-h") == 0 || strcmp(arg,"--heap") == 0) {
+        fprintf(stderr, "-h and --heap options are not presently supported\n");
+        exit(1);
+      } else if (strncmp(arg,"-s",2) == 0 || strncmp(arg,"--saveheap",10) == 0) {
+        fprintf(stderr, "-s and --saveheap options are not presently supported\n");
+        exit(1);
+#endif /* SAVEDHEAPS */
+      } else if (strcmp(arg,"--script") == 0) {
+        if (++n == argc) {
+          (void) fprintf(stderr,"%s requires argument\n", arg);
+          exit(1);
+        }
+        scriptfile = argv[n];
+        while (++n < argc) argv[new_argc++] = argv[n];
+      } else if (strcmp(arg,"--optimize-level") == 0) {
+        const char *nextarg;
+        if (++n == argc) {
+          (void) fprintf(stderr,"%s requires argument\n", arg);
+          exit(1);
+        }
+        nextarg = argv[n];
+        if (strcmp(nextarg,"0") == 0)
+          optlevel = 0;
+        else if (strcmp(nextarg,"1") == 0)
+          optlevel = 1;
+        else if (strcmp(nextarg,"2") == 0)
+          optlevel = 2;
+        else if (strcmp(nextarg,"3") == 0)
+          optlevel = 3;
+        else {
+          (void) fprintf(stderr,"invalid optimize-level %s\n", nextarg);
+          exit(1);
+        }
+      } else if (strcmp(arg,"--debug-on-exception") == 0) {
+        debug_on_exception = 1;
+      } else if (strcmp(arg,"--import-notify") == 0) {
+        import_notify = 1;
+      } else if (strcmp(arg,"--libexts") == 0) {
+        if (++n == argc) {
+          (void) fprintf(stderr,"%s requires argument\n", arg);
+          exit(1);
+        }
+        libexts = argv[n];
+      } else if (strcmp(arg,"--libdirs") == 0) {
+        if (++n == argc) {
+          (void) fprintf(stderr,"%s requires argument\n", arg);
+          exit(1);
+        }
+        libdirs = argv[n];
+      } else if (strcmp(arg,"--compile-imported-libraries") == 0) {
+        compile_imported_libraries = 1;
+      } else if (strcmp(arg,"--program") == 0) {
+        if (++n == argc) {
+          (void) fprintf(stderr,"%s requires argument\n", arg);
+          exit(1);
+        }
+        programfile = argv[n];
+        while (++n < argc) argv[new_argc++] = argv[n];
+      } else if (strcmp(arg,"--help") == 0) {
+        fprintf(stderr,"usage: %s [options and files]\n", execpath);
+        fprintf(stderr,"options:\n");
+        fprintf(stderr,"  -q, --quiet                             suppress greeting and prompt\n");
+        fprintf(stderr,"  --script <path>                         run as shell script\n");
+        fprintf(stderr,"  --program <path>                        run rnrs program as shell script\n");
+#ifdef WIN32
+#define sep ";"
+#else
+#define sep ":"
+#endif
+        fprintf(stderr,"  --libdirs <dir>%s...                     set library directories\n", sep);
+        fprintf(stderr,"  --libexts <ext>%s...                     set library extensions\n", sep);
+        fprintf(stderr,"  --compile-imported-libraries            compile libraries before loading\n");
+        fprintf(stderr,"  --import-notify                         enable import search messages\n");
+        fprintf(stderr,"  --optimize-level <0 | 1 | 2 | 3>        set optimize-level\n");
+        fprintf(stderr,"  --debug-on-exception                    on uncaught exception, call debug\n");
+        fprintf(stderr,"  --eedisable                             disable expression editor\n");
+        fprintf(stderr,"  --eehistory <off | path>                expression-editor history file\n");
+        fprintf(stderr,"  --enable-object-counts                  have collector maintain object counts\n");
+        fprintf(stderr,"  --retain-static-relocation              keep reloc info for compute-size, etc.\n");
+        fprintf(stderr,"  -b <path>, --boot <path>                load boot file\n");
+//        fprintf(stderr,"  -c, --compact                           toggle compaction flag\n");
+//        fprintf(stderr,"  -h <path>, --heap <path>                load heap file\n");
+//        fprintf(stderr,"  -s[<n>] <path>, --saveheap[<n>] <path>  save heap file\n");
+        fprintf(stderr,"  --verbose                               trace boot/heap search process\n");
+        fprintf(stderr,"  --version                               print version and exit\n");
+        fprintf(stderr,"  --help                                  print help and exit\n");
+        fprintf(stderr,"  --                                      pass through remaining args\n");
+        exit(0);
+      } else if (strcmp(arg,"--verbose") == 0) {
+        Sset_verbose(1);     
+      } else if (strcmp(arg,"--version") == 0) {
+        fprintf(stderr,"%s\n", VERSION);
+        exit(0);
+      } else {
+        argv[new_argc++] = arg;
+      }
+    }
+  }
+
+ /* must call Sbuild_heap after registering boot and heap files.
+  * Sbuild_heap() completes the initialization of the Scheme system
+  * and loads the boot or heap files.  If no boot or heap files have
+  * been registered, the first argument to Sbuild_heap must be a
+  * non-null path string; in this case, Sbuild_heap looks for
+  * a heap or boot file named <name>.boot, where <name> is the last
+  * component of the path.  If no heap files are loaded and
+  * CUSTOM_INIT is non-null, Sbuild_heap calls CUSTOM_INIT just
+  * prior to loading the boot file(s). */
+  Sbuild_heap(execpath, CUSTOM_INIT);
+
+#define CALL0(who) Scall0(Stop_level_value(Sstring_to_symbol(who)))
+#define CALL1(who, arg) Scall1(Stop_level_value(Sstring_to_symbol(who)), arg)
+#ifdef FunCRepl
+  {
+    ptr p;
+
+    for (;;) {
+        CALL1("display", Sstring("* "));
+        p = CALL0("read");
+        if (Seof_objectp(p)) break;
+        p = CALL1("eval", p);
+        if (p != Svoid) CALL1("pretty-print", p);
+    }
+    CALL0("newline");
+    status = 0;
+  }
+#else /* FunCRepl */
+  if (quiet) {
+    CALL1("suppress-greeting", Strue);
+    CALL1("waiter-prompt-string", Sstring(""));
+  }
+  if (eoc) {
+    CALL1("enable-object-counts", Strue);
+  }
+  if (optlevel != 0) {
+    CALL1("optimize-level", Sinteger(optlevel));
+  }
+  if (debug_on_exception != 0) {
+    CALL1("debug-on-exception", Strue);
+  }
+  if (import_notify != 0) {
+    CALL1("import-notify", Strue);
+  }
+  if (libdirs == 0) {
+    char *cslibdirs = GETENV("CHEZSCHEMELIBDIRS");
+    if (cslibdirs != 0) {
+      CALL1("library-directories", Sstring_utf8(cslibdirs, -1));
+      GETENV_FREE(cslibdirs);
+    }
+  } else {
+    CALL1("library-directories", Sstring_utf8(libdirs, -1));
+  }
+  if (libexts == 0) {
+    char *cslibexts = GETENV("CHEZSCHEMELIBEXTS");
+    if (cslibexts != 0) {
+      CALL1("library-extensions", Sstring_utf8(cslibexts, -1));
+      GETENV_FREE(cslibexts);
+    }
+  } else {
+    CALL1("library-extensions", Sstring_utf8(libexts, -1));
+  }
+  if (compile_imported_libraries != 0) {
+    CALL1("compile-imported-libraries", Strue);
+  }
+#ifdef FEATURE_EXPEDITOR
+ /* Senable_expeditor must be called before Scheme_start/Scheme_script (if at all) */
+  if (!quiet && expeditor_enable) Senable_expeditor(expeditor_history_file);
+#endif /* FEATURE_EXPEDITOR */
+
+  if (scriptfile != (char *)0)
+   /* Sscheme_script invokes the value of the scheme-script parameter */
+    status = Sscheme_script(scriptfile, new_argc, argv);
+  else if (programfile != (char *)0)
+   /* Sscheme_program invokes the value of the scheme-program parameter */
+    status = Sscheme_program(programfile, new_argc, argv);
+  else {
+   /* Sscheme_start invokes the value of the scheme-start parameter */
+    status = Sscheme_start(new_argc, argv);
+  }
+#endif /* FunCRepl */
+
+#ifdef SAVEDHEAPS
+  if (status == 0 && savefile != (char *)0) {
+      if (compact) Scompact_heap();
+      Ssave_heap(savefile, savefile_level);
+  }
+#endif /* SAVEDHEAPS */
+
+ /* must call Scheme_deinit after saving the heap and before exiting */
+  Sscheme_deinit();
+
+  exit(status);
+}

ta6ob/c/new-io.c

@@ -0,0 +1,970 @@
+/* new-io.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <limits.h>
+#ifdef WIN32
+#include <io.h>
+#else /* WIN32 */
+#include <sys/file.h>
+#include <dirent.h>
+#include <pwd.h>
+#endif /* WIN32 */
+#include <fcntl.h>
+#include "zlib.h"
+#include "lz4.h"
+#include "lz4hc.h"
+
+/* !!! UNLESS you enjoy spending endless days tracking down race conditions
+   !!! involving the garbage collector, please note: DEACTIVATE and
+   !!! REACTIVATE or LOCKandDEACTIVATE and REACTIVATEandLOCK should be used
+   !!! around operations that can block.  While deactivated, the process
+   !!! MUST NOT touch any unlocked Scheme objects (ptrs) or allocate any
+   !!! new Scheme objects.  It helps to bracket only small pieces of code
+   !!! with DEACTIVATE/REACTIVATE or LOCKandDEACTIVATE/REACTIVATE_and_LOCK. */
+#ifdef PTHREADS
+/* assume the scheme wrapper has us in a critical section */
+#define DEACTIVATE(tc) if (DISABLECOUNT(tc) == FIX(1)) { deactivate_thread(tc); }
+#define REACTIVATE(tc) if (DISABLECOUNT(tc) == FIX(1)) { reactivate_thread(tc); }
+#define LOCKandDEACTIVATE(tc,bv) if (DISABLECOUNT(tc) == FIX(1)) { Slock_object(bv); deactivate_thread(tc); }
+#define REACTIVATEandUNLOCK(tc,bv) if (DISABLECOUNT(tc) == FIX(1)) { reactivate_thread(tc); Sunlock_object(bv); }
+#else /* PTHREADS */
+#define DEACTIVATE(tc)
+#define REACTIVATE(tc)
+#define LOCKandDEACTIVATE(tc,bv)
+#define REACTIVATEandUNLOCK(tc,bv)
+#endif /* PTHREADS */
+
+/* locally defined functions */
+static ptr new_open_output_fd_helper(const char *filename, INT mode,
+             INT flags, INT no_create, INT no_fail, INT no_truncate,
+             INT append, INT lock, INT replace, INT compressed);
+static INT lockfile(INT fd);
+static int is_valid_zlib_length(iptr count);
+static int is_valid_lz4_length(iptr count);
+
+/*
+ not_ok_is_fatal: !ok definitely implies error, so ignore glzerror
+ ok: whether the result of body seems to be ok
+ flag: will be set when an error is detected and cleared if no error
+ fd: the glzFile object to call glzerror on
+ body: the operation we are checking the error on
+*/
+#ifdef EINTR
+/* like FD_EINTR_GUARD and GZ_EINTR_GUARD but ignores EINTR.
+   used for calls to close so we don't close a file descriptor that
+   might already have been reallocated by a different thread */
+#define FD_GUARD(ok,flag,body)                          \
+  do { body;                                            \
+    flag = !(ok) && errno != EINTR;                     \
+  } while (0)
+#define GZ_GUARD(not_ok_is_fatal,ok,flag,fd,body) \
+  do { body;                                            \
+    if (ok) { flag = 0; }                               \
+    else {                                              \
+      INT errnum;                                       \
+      S_glzerror((fd),&errnum);                         \
+      S_glzclearerr((fd));                              \
+      if (errnum == Z_ERRNO) {                          \
+        flag = errno != EINTR;                          \
+      } else {                                          \
+        flag = not_ok_is_fatal || errnum != Z_OK;       \
+        errno = 0;                                      \
+      }                                                 \
+    }                                                   \
+  } while (0)
+/* like FD_GUARD and GZ_GUARD but spins on EINTR */
+#define FD_EINTR_GUARD(ok,flag,body)                    \
+  do { body;                                            \
+    if (ok) { flag = 0; break; }                        \
+    else if (errno != EINTR) { flag = 1; break; }       \
+  } while (1)
+#define GZ_EINTR_GUARD(not_ok_is_fatal,ok,flag,fd,body) \
+  do { body;                                            \
+    if (ok) { flag = 0; break; }                        \
+    else {                                              \
+      INT errnum;                                       \
+      S_glzerror((fd),&errnum);                         \
+      S_glzclearerr((fd));                              \
+      if (errnum == Z_ERRNO) {                          \
+        if (errno != EINTR) { flag = 1; break; }        \
+      } else {                                          \
+        flag = not_ok_is_fatal || errnum != Z_OK;       \
+        errno = 0;                                      \
+        break;                                          \
+      }                                                 \
+    }                                                   \
+  } while (1)
+#else /* EINTR */
+#define FD_GUARD(ok,flag,body) do { body; flag = !(ok); } while (0)
+#define GZ_GUARD(not_ok_is_fatal,ok,flag,fd,body)       \
+  do { body;                                            \
+    if (ok) { flag = 0; }                               \
+    else {                                              \
+      INT errnum;                                       \
+      S_glzerror((fd),&errnum);                         \
+      S_glzclearerr((fd));                              \
+      if (errnum == Z_ERRNO) { flag = 1; }              \
+      else {                                            \
+        flag = not_ok_is_fatal || errnum != Z_OK;       \
+        errno = 0;                                      \
+      }                                                 \
+    }                                                   \
+  } while (0)
+#define FD_EINTR_GUARD FD_GUARD
+#define GZ_EINTR_GUARD GZ_GUARD
+#endif /* EINTR */
+
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif /* O_BINARY */
+
+
+/* These functions are intended for use immediately upon opening
+ * (lockfile) fd.  They need to be redesigned for general-purpose 
+ * locking. */
+#ifdef FLOCK
+static INT lockfile(INT fd) { return FLOCK(fd, LOCK_EX); }
+#endif
+#ifdef LOCKF
+static INT lockfile(INT fd) { return lockf(fd, F_LOCK, (off_t)0); }
+#endif
+
+#define MAKE_GZXFILE(x) Sinteger((iptr)x)
+#define GZXFILE_GZFILE(x) ((glzFile)Sinteger_value(x))
+
+INT S_gzxfile_fd(ptr x) {
+  return GZXFILE_GZFILE(x)->fd;
+}
+
+glzFile S_gzxfile_gzfile(ptr x) {
+  return GZXFILE_GZFILE(x);
+}
+
+ptr S_new_open_input_fd(const char *infilename, IBOOL compressed) {
+  char *filename;
+  INT saved_errno = 0;
+  INT fd, dupfd, error, result, ok, flag;
+  glzFile file;
+#ifdef PTHREADS
+  ptr tc = get_thread_context();
+#endif
+
+  filename = S_malloc_pathname(infilename);
+
+  /* NB: don't use infilename, which might point into a Scheme string, after this point */
+  DEACTIVATE(tc)
+  FD_EINTR_GUARD(fd>=0, error, fd=OPEN(filename,O_BINARY|O_RDONLY,0));
+  saved_errno = errno;
+  REACTIVATE(tc)
+
+  /* NB: don't use free'd filename after this point */
+  free(filename);
+
+  if (error) {
+    ptr str = S_strerror(saved_errno);
+    switch (saved_errno) {
+      case EACCES:
+        return Scons(FIX(OPEN_ERROR_PROTECTION), str);
+      case ENOENT:
+        return Scons(FIX(OPEN_ERROR_EXISTSNOT), str);
+      default:
+        return Scons(FIX(OPEN_ERROR_OTHER), str);
+    }
+  }
+
+  if (!compressed) {
+    return MAKE_FD(fd);
+  }
+    
+  if ((dupfd = DUP(fd)) == -1) {
+    ptr str = S_strerror(errno);
+    FD_GUARD(result == 0, error, result = CLOSE(fd));
+    return Scons(FIX(OPEN_ERROR_OTHER), str);
+  }
+  
+  DEACTIVATE(tc) /* glzdopen_input reads the magic word from the file */
+  if ((file = S_glzdopen_input(dupfd)) == Z_NULL) {
+    REACTIVATE(tc)
+    FD_GUARD(result == 0, error, result = CLOSE(fd));
+    FD_GUARD(result == 0, error, result = CLOSE(dupfd));
+    return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state (too many open files?)"));
+  }
+
+  compressed = !S_glzdirect(file);
+  REACTIVATE(tc)
+
+  if (compressed) {
+    FD_GUARD(result == 0, error, result = CLOSE(fd));
+    /* box indicates compressed */
+    return Sbox(MAKE_GZXFILE(file));
+  }
+
+  GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = S_glzclose(file));
+  if (flag) {} /* make the compiler happy */
+  if (LSEEK(fd, 0, SEEK_SET) != 0) { /* glzdopen and glzdirect might not leave fd at position 0 */
+    FD_GUARD(result == 0, error, result = CLOSE(fd));
+    return Scons(FIX(OPEN_ERROR_OTHER),Sstring("unable to reset after reading header bytes"));
+  }
+  return MAKE_FD(fd);
+}
+
+ptr S_compress_input_fd(INT fd, I64 pos) {
+  INT dupfd, error, result, ok, flag; IBOOL compressed;
+  glzFile file;
+#ifdef PTHREADS
+  ptr tc = get_thread_context();
+#endif
+
+  if ((dupfd = DUP(fd)) == -1) {
+    return S_strerror(errno);
+  }
+  
+  DEACTIVATE(tc)
+  if ((file = S_glzdopen_input(dupfd)) == Z_NULL) {
+    REACTIVATE(tc)
+    FD_GUARD(result == 0, error, result = CLOSE(dupfd));
+    return Sstring("unable to allocate compression state (too many open files?)");
+  }
+  
+  compressed = !S_glzdirect(file);
+  REACTIVATE(tc)
+
+  if (compressed) {
+    FD_GUARD(result == 0, error, result = CLOSE(fd));
+    if (error) {} /* make the compiler happy */
+    /* box indicates compressed */
+    return Sbox(MAKE_GZXFILE(file));
+  }
+
+  GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = S_glzclose(file));
+  if (flag) {} /* make the compiler happy */
+  if (LSEEK(fd, pos, SEEK_SET) != pos) { /* glzdirect does not leave fd at same position */
+    return Sstring("unable to reset after reading header bytes");
+  }
+  return MAKE_FD(fd);
+}
+
+ptr S_compress_output_fd(INT fd) {
+  glzFile file;
+  ptr tc = get_thread_context();
+
+  file = S_glzdopen_output(fd, (INT)UNFIX(COMPRESSFORMAT(tc)), (INT)UNFIX(COMPRESSLEVEL(tc)));
+
+  if (file == Z_NULL)
+    return Sstring("unable to allocate compression state (too many open files?)");
+
+  /* box indicates compressed */
+  return Sbox(MAKE_GZXFILE(file));
+}
+
+static ptr new_open_output_fd_helper(
+  const char *infilename, INT mode, INT flags,
+  IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
+  IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) {
+  char *filename;
+  INT saved_errno = 0;
+  iptr error;
+  INT fd, result;
+  ptr tc = get_thread_context();
+
+  flags |=
+    (no_create ? 0 : O_CREAT) |
+    ((no_fail || no_create) ? 0 : O_EXCL) |
+    (no_truncate ? 0 : O_TRUNC) |
+    ((!append) ? 0 : O_APPEND);
+
+  filename = S_malloc_pathname(infilename);
+  
+  if (replace && UNLINK(filename) != 0 && errno != ENOENT) {
+    ptr str = S_strerror(errno);
+    switch (errno) {
+      case EACCES:
+        return Scons(FIX(OPEN_ERROR_PROTECTION), str);
+      default:
+        return Scons(FIX(OPEN_ERROR_OTHER), str);
+    }
+  }
+  
+  /* NB: don't use infilename, which might point into a Scheme string, after this point */
+  DEACTIVATE(tc)
+  FD_EINTR_GUARD(fd >= 0, error, fd = OPEN(filename, flags, mode));
+  saved_errno = errno;
+  REACTIVATE(tc)
+
+  /* NB: don't use free'd filename after this point */
+  free(filename);
+
+  if (error) {
+    ptr str = S_strerror(saved_errno);
+    switch (saved_errno) {
+      case EACCES:
+        return Scons(FIX(OPEN_ERROR_PROTECTION), str);
+      case EEXIST:
+        return Scons(FIX(OPEN_ERROR_EXISTS), str);
+      case ENOENT:
+        return Scons(FIX(OPEN_ERROR_EXISTSNOT), str);
+      default:
+        return Scons(FIX(OPEN_ERROR_OTHER), str);
+    }
+  }
+  
+  if (lock) {
+    DEACTIVATE(tc)
+    error = lockfile(fd);
+    saved_errno = errno;
+    REACTIVATE(tc)
+    if (error) {
+      FD_GUARD(result == 0, error, result = CLOSE(fd));
+      return Scons(FIX(OPEN_ERROR_OTHER), S_strerror(saved_errno));
+    }
+  }
+  
+  if (!compressed) {
+    return MAKE_FD(fd);
+  }
+
+  glzFile file;
+  file = S_glzdopen_output(fd, (INT)UNFIX(COMPRESSFORMAT(tc)), (INT)UNFIX(COMPRESSLEVEL(tc)));
+  if (file == Z_NULL) {
+    FD_GUARD(result == 0, error, result = CLOSE(fd));
+    return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state"));
+  }
+
+  return MAKE_GZXFILE(file);
+}
+
+ptr S_new_open_output_fd(
+  const char *filename, INT mode,
+  IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
+  IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) {
+  return new_open_output_fd_helper(
+    filename, mode, O_BINARY | O_WRONLY,
+    no_create, no_fail, no_truncate,
+    append, lock, replace, compressed);
+}
+
+ptr S_new_open_input_output_fd(
+  const char *filename, INT mode,
+  IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
+  IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) {
+  if (compressed)
+    return Sstring("compressed input/output files not supported");
+  else
+    return new_open_output_fd_helper(
+      filename, mode, O_BINARY | O_RDWR,
+      no_create, no_fail, no_truncate,
+      append, lock, replace, 0);
+}
+
+ptr S_close_fd(ptr file, IBOOL gzflag) {
+  INT saved_errno = 0;
+  INT ok, flag;
+  INT fd = gzflag ? 0 : GET_FD(file);
+  glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
+#ifdef PTHREADS
+  ptr tc = get_thread_context();
+#endif
+
+ /* refuse to close stdin, stdout, and stderr fds */
+  if (!gzflag && fd <= 2) return Strue;
+
+ /* file is not locked; do not reference after deactivating thread! */
+  file = (ptr)-1;
+
+ /* NOTE: close automatically releases locks so we don't to call unlock*/
+  DEACTIVATE(tc)
+  if (!gzflag) {
+    FD_GUARD(ok == 0, flag, ok = CLOSE(fd));
+  } else {
+   /* zlib 1.2.1 returns Z_BUF_ERROR when closing an empty file opened for reading */
+    GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, gzfile, ok = S_glzclose(gzfile));
+  }
+  saved_errno = errno;
+  REACTIVATE(tc)
+
+  if (!flag) {
+    return Strue;
+  }
+
+  if (gzflag && saved_errno == 0) {
+    return Sstring("compression failed");
+  }
+
+  return S_strerror(saved_errno);
+}
+
+#define GZ_IO_SIZE_T unsigned int
+
+#ifdef WIN32
+#define IO_SIZE_T unsigned int
+static HANDLE hStdin = NULL;
+static iptr read_console(char* buf, unsigned size) {
+  static char u8buf[1024];
+  static int u8i = 0;
+  static int u8n = 0;
+  iptr n = 0;
+  do {
+    for (; size > 0 && u8n > 0; size--, u8n--, n++)
+      *buf++ = u8buf[u8i++];
+    if (n == 0 && size > 0) {
+      wchar_t wbuf[256];
+      DWORD wn;
+      if (!ReadConsoleW(hStdin, wbuf, 256, &wn, NULL) || wn == 0)
+        return 0;
+      u8n = WideCharToMultiByte(CP_UTF8, 0, wbuf, wn, u8buf, 1024, NULL, NULL);
+      u8i = 0;
+    }
+  } while (n == 0);
+  return n;
+}
+#else /* WIN32 */
+#define IO_SIZE_T size_t
+#endif /* WIN32 */
+
+/* Returns string on error, #!eof on end-of-file and integer-count otherwise */
+ptr S_bytevector_read(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
+  INT saved_errno = 0;
+  ptr tc = get_thread_context();
+  iptr m, flag = 0;
+  INT fd = gzflag ? 0 : GET_FD(file);
+  glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
+
+ /* file is not locked; do not reference after deactivating thread! */
+  file = (ptr)-1;
+
+#if (iptr_bits > 32)
+  if ((WIN32 || gzflag) && (unsigned int)count != count) count = 0xffffffff;
+#endif
+
+  LOCKandDEACTIVATE(tc, bv)
+#ifdef CHECK_FOR_ROSETTA
+  /* If we are running on Apple Silicon under Rosetta 2 translation, work around
+     a bug (present in 11.2.3 at least) in its handling of memory page protection
+     bits.  One of the tasks that Rosetta handles is to appropriately twiddle the
+     execute and write bits based on what's happening to the memory in order to
+     preserve the illusion that the pages have RWX permissions, whereas Apple
+     Silicon enforces a W^X (write XOR execute) model.  For some reason, this
+     bit-twiddling sometimes fails when the bytevector passed to `read` extends
+     onto a page that's currently R-X, causing the `read` to fail with EFAULT
+     ("bad address").  By writing to each subsequent page, we force Rosetta to
+     do the right magic to the protection bits.  (Or at least it makes the error
+     go away and all the mats pass.)
+     */
+  if (is_rosetta) {
+    for (iptr idx = start+count; idx > start; idx -= S_pagesize) {
+      volatile octet b = BVIT(bv,idx);
+      BVIT(bv,idx) = b;
+    }
+  }
+#endif
+
+#ifdef WIN32
+  if (!gzflag && fd == 0 && hStdin != NULL) {
+    DWORD error_code;
+    SetConsoleCtrlHandler(NULL, TRUE);
+    SetLastError(0);
+    m = read_console(&BVIT(bv,start), (IO_SIZE_T)count);
+    error_code = GetLastError();
+    if (m == 0 && error_code == 0x3e3) {
+      /* Guard against Windows calling the ConsoleCtrlHandler after we
+       * turn it back on by waiting a bit. */
+      Sleep(1);
+#ifdef PTHREADS
+      /* threaded io.ss doesn't handle interrupts because
+       * with-tc-mutex disables them, so bail out. */
+      SetConsoleCtrlHandler(NULL, FALSE);
+      REACTIVATEandUNLOCK(tc, bv)
+      S_noncontinuable_interrupt();
+#else
+      KEYBOARDINTERRUPTPENDING(tc) = Strue;
+      SOMETHINGPENDING(tc) = Strue;
+#endif
+    }
+    SetConsoleCtrlHandler(NULL, FALSE);
+  } else
+#endif /* WIN32 */
+  {
+    if (!gzflag) {
+      FD_EINTR_GUARD(
+        m >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)), flag,
+        m = READ(fd,&BVIT(bv,start),(IO_SIZE_T)count));
+    } else {
+      GZ_EINTR_GUARD(
+        1, m >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
+        flag, gzfile,
+        m = S_glzread(gzfile, &BVIT(bv,start), (GZ_IO_SIZE_T)count));
+    }
+  }
+  saved_errno = errno;
+  REACTIVATEandUNLOCK(tc, bv)
+
+  if (Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) {
+    return Sstring("interrupt");
+  }
+
+  if (!flag) {
+    return m == 0 ? Seof_object : FIX(m);
+  }
+
+  if (saved_errno == EAGAIN) {
+    return FIX(0);
+  }
+
+  return S_strerror(saved_errno);
+}
+
+/* Returns:
+    string on error, including if not supported,
+    n when read,
+    0 on non-blocking and
+    #!eof otherwise */
+ptr S_bytevector_read_nb(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
+#ifdef WIN32
+  HANDLE h;
+
+ /* assume compressed files are always ready */
+  if (gzflag) return FIX(1);
+
+  if ((h = (HANDLE)_get_osfhandle(GET_FD(file))) != INVALID_HANDLE_VALUE) {
+    switch (GetFileType(h)) {
+      case FILE_TYPE_CHAR:
+       /* if h is hStdin, PeekConsoleInput can tell us if a key down event
+          is waiting, but if it's not a newline, we can't be sure that
+          a read will succeed.  so PeekConsoleInput is basically useless
+          for our purposes. */
+        break;
+      case FILE_TYPE_PIPE: {
+        DWORD bytes;
+        if (PeekNamedPipe(h, NULL, 0, NULL, &bytes, NULL) && bytes == 0) return FIX(0);
+       /* try the read on error or if bytes > 0 */
+        return S_bytevector_read(file, bv, start, count, gzflag);
+      }
+      default: {
+        if (WaitForSingleObject(h, 0) == WAIT_TIMEOUT) return FIX(0);
+       /* try the read on error or if bytes > 0 */
+        return S_bytevector_read(file, bv, start, count, gzflag);
+      }
+    }
+  }
+
+  return Sstring("cannot determine ready status");
+#else /* WIN32 */
+  INT fcntl_flags;
+  ptr result;
+  INT fd;
+
+ /* assume compressed files are always ready */
+  if (gzflag) return FIX(1);
+
+  fd = GET_FD(file);
+
+ /* set NOBLOCK for nonblocking read */
+  fcntl_flags = fcntl(fd, F_GETFL, 0);
+  if (!(fcntl_flags & NOBLOCK)) (void) fcntl(fd, F_SETFL, fcntl_flags | NOBLOCK);
+
+  result = S_bytevector_read(file, bv, start, count, gzflag);
+
+ /* reset NOBLOCK for normal blocking read */
+  if (!(fcntl_flags & NOBLOCK)) (void) fcntl(fd, F_SETFL, fcntl_flags);
+
+  return result;
+#endif /* WIN32 */
+}
+
+ptr S_bytevector_write(ptr file, ptr bv, iptr start, iptr count, IBOOL gzflag) {
+  iptr i, s, c;
+  ptr tc = get_thread_context();
+  INT flag = 0, saved_errno = 0;
+  INT fd = gzflag ? 0 : GET_FD(file);
+  glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
+
+  for (s = start, c = count; c > 0; s += i, c -= i) {
+    iptr cx = c;
+
+#if (iptr_bits > 32)
+  if ((WIN32 || gzflag) && (unsigned int)cx != cx) cx = 0xffffffff;
+#endif
+
+  /* if we could know that fd is nonblocking, we wouldn't need to deactivate.
+     we could test ioctl, but some other thread could change it before we actually
+     get around to writing. */
+    LOCKandDEACTIVATE(tc, bv)
+    if (gzflag) {
+     /* strangely, gzwrite returns 0 on error */
+      GZ_EINTR_GUARD(
+        i < 0, i > 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
+        flag, gzfile,
+        i = S_glzwrite(gzfile, &BVIT(bv,s), (GZ_IO_SIZE_T)cx));
+    } else {
+      FD_EINTR_GUARD(i >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
+                     flag, i = WRITE(fd, &BVIT(bv,s), (IO_SIZE_T)cx));
+    }
+    saved_errno = errno;
+    REACTIVATEandUNLOCK(tc, bv)
+
+    if (flag) {
+      if (saved_errno == EAGAIN) { flag = 0; }
+      break;
+    }
+
+   /* we escape from loop if keyboard interrupt is pending, but this won't
+      do much good until we fix up the interrupt protocol to guarantee
+      that the interrupt handler is actually called */
+    if (Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) {
+      if (i >= 0) s += i;
+      break;
+    }
+  }
+
+  if (!flag) {
+    return FIX(s - start);
+  }
+
+  if (saved_errno == EAGAIN) {
+    return FIX(0);
+  }
+
+  if (gzflag && saved_errno == 0) {
+    return Sstring("compression failed");
+  }
+
+  return S_strerror(saved_errno);
+}
+
+/* S_put_byte is a simplified version of S_bytevector_write for writing one
+   byte on unbuffered ports */
+ptr S_put_byte(ptr file, INT byte, IBOOL gzflag) {
+  iptr i;
+  ptr tc = get_thread_context();
+  INT flag = 0, saved_errno = 0;
+  INT fd = gzflag ? 0 : GET_FD(file);
+  glzFile gzfile = gzflag ? GZXFILE_GZFILE(file) : NULL;
+  octet buf[1];
+
+  buf[0] = (octet)byte;
+
+  DEACTIVATE(tc)
+  if (gzflag) {
+   /* strangely, gzwrite returns 0 on error */
+    GZ_EINTR_GUARD(
+      i < 0, i > 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
+      flag, gzfile,
+      i = S_glzwrite(gzfile, buf, 1));
+  } else {
+    FD_EINTR_GUARD(i >= 0 || Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)),
+                   flag, i = WRITE(fd, buf, 1));
+  }
+  saved_errno = errno;
+  REACTIVATE(tc)
+
+  if (flag) {
+    if (saved_errno == EAGAIN) { flag = 0; }
+  }
+
+  if (!flag) {
+    return FIX(i);
+  }
+
+  if (saved_errno == EAGAIN) {
+    return FIX(0);
+  }
+
+  if (gzflag && saved_errno == 0) {
+    return Sstring("compression failed");
+  }
+
+  return S_strerror(saved_errno);
+}
+
+ptr S_get_fd_pos(ptr file, IBOOL gzflag) {
+  errno = 0;
+  if (gzflag) {
+    z_off_t offset = S_glzseek(GZXFILE_GZFILE(file), 0, SEEK_CUR);
+    if (offset != -1) return Sinteger64(offset);
+  } else {
+    OFF_T offset = LSEEK(GET_FD(file), 0, SEEK_CUR);
+    if (offset != -1) return Sinteger64(offset);
+  }
+  if (gzflag && errno == 0) return Sstring("compression failed");
+  return S_strerror(errno);
+}
+
+/* assume wrapper ensures 0 <= pos <= 2^63-1 */
+ptr S_set_fd_pos(ptr file, ptr pos, IBOOL gzflag) {
+  I64 offset64 = S_int64_value("set-file-position", pos);
+
+  if (gzflag) {
+    z_off_t offset = (z_off_t)offset64;
+    if (sizeof(z_off_t) != sizeof(I64))
+      if (offset != offset64) return Sstring("invalid position");
+    errno = 0;
+    if (S_glzseek(GZXFILE_GZFILE(file),offset,SEEK_SET) == offset) return Strue;
+    if (errno == 0) return Sstring("compression failed");
+    return S_strerror(errno);
+  } else {
+    OFF_T offset = (OFF_T)offset64;
+    if (sizeof(OFF_T) != sizeof(I64))
+      if (offset != offset64) return Sstring("invalid position");
+    if (LSEEK(GET_FD(file), offset, SEEK_SET) == offset) return Strue;
+    return S_strerror(errno);
+  }
+}
+
+ptr S_get_fd_non_blocking(ptr file, IBOOL gzflag) {
+#ifdef WIN32
+  return Sfalse;
+#else /* WIN32 */
+  INT fcntl_flags;
+
+  if (gzflag) return Sfalse;
+
+  fcntl_flags = fcntl(GET_FD(file), F_GETFL, 0);
+
+  if (fcntl_flags == -1) {
+    return S_strerror(errno);
+  }
+
+  return Sboolean(NOBLOCK & fcntl_flags);
+#endif /* WIN32 */
+}
+
+ptr S_set_fd_non_blocking(ptr file, IBOOL x, IBOOL gzflag) {
+#ifdef WIN32
+  return Sstring("unsupported");
+#else /* WIN32 */
+  iptr fd;
+  INT fcntl_flags;
+
+  if (gzflag) {
+    if (x) return Sstring("Compressed non-blocking ports not supported");
+    else return Strue;
+  }
+
+  fd = GET_FD(file);
+  fcntl_flags = fcntl(fd, F_GETFL, 0);
+
+  if (fcntl_flags == -1) {
+    return S_strerror(errno);
+  }
+
+  if (x) {
+    if (fcntl_flags & NOBLOCK) {
+      return Strue;
+    }
+    if (0 == fcntl(fd, F_SETFL, fcntl_flags | NOBLOCK)) {
+      return Strue;
+    }
+    return S_strerror(errno);
+  } else {
+    if (!(fcntl_flags & NOBLOCK)) {
+      return Strue;
+    }
+    if (0 == fcntl(fd, F_SETFL, fcntl_flags & ~NOBLOCK)) {
+      return Strue;
+    }
+    return S_strerror(errno);
+  }
+#endif /* WIN32 */
+}
+
+ptr S_get_fd_length(ptr file, IBOOL gzflag) {
+  struct STATBUF statbuf;
+
+  if (gzflag) return Sstring("Not supported on compressed files");
+
+  if (FSTAT(GET_FD(file), &statbuf) == 0) {
+    return Sinteger64(statbuf.st_size);
+  }
+
+  return S_strerror(errno);    
+}
+
+ptr S_set_fd_length(ptr file, ptr length, IBOOL gzflag) {
+  INT fd, ok, flag = 0;
+  I64 len64; off_t len;
+#ifdef PTHREADS
+  ptr tc = get_thread_context();
+#endif
+
+  if (gzflag) return Sstring("Not supported on compressed files");
+
+  len64 = S_int64_value("set-file-length", length);
+  len = (off_t)len64;
+  if (sizeof(off_t) != sizeof(I64))
+    if (len != len64) return Sstring("invalid length");
+
+  fd = GET_FD(file);
+  DEACTIVATE(tc)
+  FD_EINTR_GUARD(ok == 0, flag, ok = ftruncate(fd, len));
+  REACTIVATE(tc)
+
+  return flag ? S_strerror(errno) : Strue;
+}
+
+void S_new_io_init(void) {
+  if (S_boot_time) {
+    S_set_symbol_value(S_intern((const unsigned char *)"$c-bufsiz"), Sinteger(SBUFSIZ));
+  }
+#ifdef WIN32
+  { /* Get the console input handle for reading Unicode characters */
+    HANDLE h;
+    DWORD mode;
+    if ((h = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE
+        && GetConsoleMode(h, &mode))
+      hStdin = h;
+  }
+ /* transcoder, if any, does its own cr, lf translations */
+  _setmode(_fileno(stdin), O_BINARY);
+  _setmode(_fileno(stdout), O_BINARY);
+  _setmode(_fileno(stderr), O_BINARY);
+  /* Set the console output to handle UTF-8 */
+  SetConsoleOutputCP(CP_UTF8);
+#endif /* WIN32 */
+}
+
+static int is_valid_zlib_length(iptr count) {
+  /* A zlib `uLong` may be the same as `unsigned long`,
+     which is not as big as `iptr` on 64-bit Windows. */
+  return count == (iptr)(uLong)count;
+}
+
+static int is_valid_lz4_length(iptr len) {
+  return (len <= LZ4_MAX_INPUT_SIZE);
+}
+
+/* Accept `iptr` because we expect it to represent a bytevector size,
+   which always fits in `iptr`. Return `uptr`, because the result might
+   not fit in `iptr`. */
+uptr S_bytevector_compress_size(iptr s_count, INT compress_format) {
+  switch (compress_format) {
+    case COMPRESS_GZIP:
+      if (is_valid_zlib_length(s_count))
+        return compressBound((uLong)s_count);
+      else {
+        /* Compression will report "source too long" */
+        return 0;
+      }
+    case COMPRESS_LZ4:
+      if (is_valid_lz4_length(s_count))
+        return LZ4_compressBound((uLong)s_count);
+      else {
+        /* Compression will report "source too long" */
+        return 0;
+      }
+    default:
+      S_error1("S_bytevector_compress_size", "unexpected compress format ~s", FIX(compress_format));
+      return 0;
+  }
+}
+
+ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
+                          ptr src_bv, iptr s_start, iptr s_count,
+                          INT compress_format) {
+  ptr tc = get_thread_context();
+  int compress_level = (INT)UNFIX(COMPRESSLEVEL(tc));
+
+  /* On error, an message-template string with ~s for the bytevector */
+  switch (compress_format) {
+    case COMPRESS_GZIP:
+      {
+        int r;
+        uLong destLen;
+
+        if (!is_valid_zlib_length(s_count))
+          return Sstring("source bytevector ~s is too large");
+
+        destLen = (uLong)d_count;
+
+        r = compress2(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count, S_zlib_compress_level(compress_level));
+
+        if (r == Z_OK)
+          return FIX(destLen);
+        else if (r == Z_BUF_ERROR)
+          return Sstring("destination bytevector is too small for compressed form of ~s");
+        else
+          return Sstring("internal error compressing ~s");
+      }
+    case COMPRESS_LZ4:
+      {
+        int destLen;
+
+        if (!is_valid_lz4_length(s_count))
+          return Sstring("source bytevector ~s is too large");
+
+        if (compress_level == COMPRESS_MIN) {
+          destLen = LZ4_compress_default((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count);
+        } else {
+          destLen = LZ4_compress_HC((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count, S_lz4_compress_level(compress_level));
+        }
+
+        if (destLen > 0)
+          return Sfixnum(destLen);
+        else
+          return Sstring("compression failed for ~s");
+      }
+    default:
+      S_error1("S_bytevector_compress", "unexpected compress format ~s", FIX(compress_format));
+      return Sfalse;
+  }
+}
+
+ptr S_bytevector_uncompress(ptr dest_bv, iptr d_start, iptr d_count,
+                            ptr src_bv, iptr s_start, iptr s_count,
+                            INT compress_format) {
+  /* On error, an message-template string with ~s for the bytevector */
+  switch (compress_format) {
+    case COMPRESS_GZIP:
+      {
+        int r;
+        uLongf destLen;
+
+        if (!is_valid_zlib_length(d_count))
+          return Sstring("expected result size of uncompressed source ~s is too large");
+
+        destLen = (uLongf)d_count;
+
+        r = uncompress(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count);
+
+        if (r == Z_OK)
+          return FIX(destLen);
+        else if (r == Z_BUF_ERROR)
+          return Sstring("uncompressed ~s is larger than expected size");
+        else if (r == Z_DATA_ERROR)
+          return Sstring("invalid data in source bytevector ~s");
+        else
+          return Sstring("internal error uncompressing ~s");
+      }
+    case COMPRESS_LZ4:
+      {
+        int r;
+
+        if (!is_valid_lz4_length(d_count))
+          return Sstring("expected result size of uncompressed source ~s is too large");
+
+        r = LZ4_decompress_safe((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count);
+
+        if (r >= 0)
+          return Sfixnum(r);
+        else
+          return Sstring("internal error uncompressing ~s");
+      }
+    default:
+      return Sstring("unexpected compress format ~s");
+  }
+}

ta6ob/c/nocurses.h

@@ -0,0 +1,24 @@
+#ifndef ERR
+# define ERR               -1
+#endif
+
+#define setupterm(a, b, e) (*(e) = 0, ERR)
+#define tputs(c, x, f)     (f(c))
+
+#define lines              0
+#define columns            0
+
+#define cursor_left        0
+#define cursor_right       0
+#define cursor_up          0
+#define cursor_down        0
+#define enter_am_mode      0
+#define exit_am_mode       0
+#define clr_eos            0
+#define clr_eol            0
+#define clear_screen       0
+#define carriage_return    0
+#define bell               0
+#define scroll_reverse     0
+#define auto_right_margin  0
+#define eat_newline_glitch 0

ta6ob/c/prim.c

@@ -0,0 +1,288 @@
+/* prim.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+/* locally defined functions */
+static void install_library_entry(ptr n, ptr x);
+static void scheme_install_library_entry(void);
+static void create_library_entry_vector(void);
+static void install_c_entry(iptr i, ptr x);
+static void create_c_entry_vector(void);
+static void s_instantiate_code_object(void);
+static void s_link_code_object(ptr co, ptr objs);
+static IBOOL s_check_heap_enabledp(void);
+static void s_enable_check_heap(IBOOL b);
+static uptr s_check_heap_errors(void);
+
+static void install_library_entry(ptr n, ptr x) {
+    if (!Sfixnump(n) || UNFIX(n) < 0 || UNFIX(n) >= library_entry_vector_size)
+        S_error1("$install-library-entry", "invalid index ~s", n);
+    if (!Sprocedurep(x) && !Scodep(x))
+        S_error2("$install-library-entry", "invalid entry ~s for ~s", x, n);
+    if (Svector_ref(S_G.library_entry_vector, UNFIX(n)) != Sfalse) {
+        printf("$install-library-entry: overwriting entry for %ld\n", (long)UNFIX(n));
+        fflush(stdout);
+    }
+    SETVECTIT(S_G.library_entry_vector, UNFIX(n), x);
+    if (n == FIX(library_nonprocedure_code)) {
+        S_G.nonprocedure_code = x;
+        S_retrofit_nonprocedure_code();
+    }
+}
+
+ptr S_lookup_library_entry(iptr n, IBOOL errorp) {
+    ptr p;
+
+    if (n < 0 || n >= library_entry_vector_size)
+        S_error1("$lookup-library-entry", "invalid index ~s", FIX(n));
+    p = Svector_ref(S_G.library_entry_vector, n);
+    if (p == Sfalse && errorp)
+        S_error1("$lookup-library-entry", "entry ~s uninitialized", FIX(n));
+    return p;
+}
+
+static void scheme_install_library_entry(void) {
+    ptr tc = get_thread_context();
+    install_library_entry(S_get_scheme_arg(tc, 1), S_get_scheme_arg(tc, 2));
+}
+
+static void create_library_entry_vector(void) {
+    iptr i;
+
+    S_protect(&S_G.library_entry_vector);
+    S_G.library_entry_vector = S_vector(library_entry_vector_size);
+    for (i = 0; i < library_entry_vector_size; i++)
+        INITVECTIT(S_G.library_entry_vector, i) = Sfalse;
+}
+
+#ifdef HPUX
+#define proc2ptr(x) int2ptr((iptr)(x))
+ptr int2ptr(iptr f)
+{
+   if ((f & 2) == 0)
+      S_error("proc2ptr", "invalid C procedure");
+   return (ptr)(f & ~0x3);
+}
+#else /* HPUX */
+#define proc2ptr(x) (ptr)(iptr)(x)
+#endif /* HPUX */
+
+static void install_c_entry(iptr i, ptr x) {
+    if (i < 0 || i >= c_entry_vector_size)
+        S_error1("install_c_entry", "invalid index ~s", FIX(i));
+    if (Svector_ref(S_G.c_entry_vector, i) != Sfalse)
+        S_error1("install_c_entry", "duplicate entry for ~s", FIX(i));
+    SETVECTIT(S_G.c_entry_vector, i, x);
+}
+
+ptr S_lookup_c_entry(iptr i) {
+   ptr x;
+
+   if (i < 0 || i >= c_entry_vector_size)
+       S_error1("lookup_c_entry", "invalid index ~s", FIX(i));
+   if ((x = Svector_ref(S_G.c_entry_vector, i)) == Sfalse)
+       S_error1("lookup_c_entry", "uninitialized entry ~s", FIX(i));
+   return x;
+}
+
+static ptr s_get_thread_context(void) {
+  return get_thread_context();
+}
+
+static void create_c_entry_vector(void) {
+    INT i;
+
+    S_protect(&S_G.c_entry_vector);
+    S_G.c_entry_vector = S_vector(c_entry_vector_size);
+
+    for (i = 0; i < c_entry_vector_size; i++)
+        INITVECTIT(S_G.c_entry_vector, i) = Sfalse;
+
+    install_c_entry(CENTRY_thread_context, proc2ptr(S_G.thread_context));
+    install_c_entry(CENTRY_get_thread_context, proc2ptr(s_get_thread_context));
+    install_c_entry(CENTRY_handle_apply_overflood, proc2ptr(S_handle_apply_overflood));
+    install_c_entry(CENTRY_handle_docall_error, proc2ptr(S_handle_docall_error));
+    install_c_entry(CENTRY_handle_overflow, proc2ptr(S_handle_overflow));
+    install_c_entry(CENTRY_handle_overflood, proc2ptr(S_handle_overflood));
+    install_c_entry(CENTRY_handle_nonprocedure_symbol, proc2ptr(S_handle_nonprocedure_symbol));
+    install_c_entry(CENTRY_thread_list, (ptr)&S_threads);
+    install_c_entry(CENTRY_split_and_resize, proc2ptr(S_split_and_resize));
+#ifdef PTHREADS
+    install_c_entry(CENTRY_raw_collect_cond, (ptr)&S_collect_cond);
+    install_c_entry(CENTRY_raw_tc_mutex, (ptr)&S_tc_mutex);
+    install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread));
+    install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread));
+    install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread));
+#endif /* PTHREADS */
+    install_c_entry(CENTRY_handle_values_error, proc2ptr(S_handle_values_error));
+    install_c_entry(CENTRY_handle_mvlet_error, proc2ptr(S_handle_mvlet_error));
+    install_c_entry(CENTRY_handle_arg_error, proc2ptr(S_handle_arg_error));
+    install_c_entry(CENTRY_foreign_entry, proc2ptr(S_foreign_entry));
+    install_c_entry(CENTRY_install_library_entry, proc2ptr(scheme_install_library_entry));
+    install_c_entry(CENTRY_get_more_room, proc2ptr(S_get_more_room));
+    install_c_entry(CENTRY_scan_remembered_set, proc2ptr(S_scan_remembered_set));
+    install_c_entry(CENTRY_instantiate_code_object, proc2ptr(s_instantiate_code_object));
+    install_c_entry(CENTRY_Sreturn, proc2ptr(S_return));
+    install_c_entry(CENTRY_Scall_one_result, proc2ptr(S_call_one_result));
+    install_c_entry(CENTRY_Scall_any_results, proc2ptr(S_call_any_results));
+
+    for (i = 0; i < c_entry_vector_size; i++) {
+#ifndef PTHREADS
+      if (i == CENTRY_raw_collect_cond || i == CENTRY_raw_tc_mutex
+          || i == CENTRY_activate_thread || i == CENTRY_deactivate_thread
+          || i == CENTRY_unactivate_thread)
+        continue;
+#endif /* NOT PTHREADS */
+      if (Svector_ref(S_G.c_entry_vector, i) == Sfalse) {
+        fprintf(stderr, "c_entry_vector entry %d is uninitialized\n", i);
+        S_abnormal_exit();
+      }
+    }
+}
+
+void S_prim_init(void) {
+    if (!S_boot_time) return;
+
+    create_library_entry_vector();
+    create_c_entry_vector();
+
+    Sforeign_symbol("(cs)fixedpathp", (void *)S_fixedpathp);
+    Sforeign_symbol("(cs)bytes_allocated", (void *)S_compute_bytes_allocated);
+    Sforeign_symbol("(cs)curmembytes", (void *)S_curmembytes);
+    Sforeign_symbol("(cs)maxmembytes", (void *)S_maxmembytes);
+    Sforeign_symbol("(cs)resetmaxmembytes", (void *)S_resetmaxmembytes);
+    Sforeign_symbol("(cs)do_gc", (void *)S_do_gc);
+    Sforeign_symbol("(cs)check_heap_enabledp", (void *)s_check_heap_enabledp);
+    Sforeign_symbol("(cs)enable_check_heap", (void *)s_enable_check_heap);
+    Sforeign_symbol("(cs)check_heap_errors", (void *)s_check_heap_errors);
+    Sforeign_symbol("(cs)lookup_library_entry", (void *)S_lookup_library_entry);
+    Sforeign_symbol("(cs)link_code_object", (void *)s_link_code_object);
+    Sforeign_symbol("(cs)lookup_c_entry", (void *)S_lookup_c_entry);
+    Sforeign_symbol("(cs)lock_object", (void *)Slock_object);
+    Sforeign_symbol("(cs)unlock_object", (void *)Sunlock_object);
+    Sforeign_symbol("(cs)locked_objectp", (void *)Slocked_objectp);
+    Sforeign_symbol("(cs)locked_objects", (void *)S_locked_objects);
+    Sforeign_symbol("(cs)maxgen", (void *)S_maxgen);
+    Sforeign_symbol("(cs)set_maxgen", (void *)S_set_maxgen);
+    Sforeign_symbol("(cs)minfreegen", (void *)S_minfreegen);
+    Sforeign_symbol("(cs)set_minfreegen", (void *)S_set_minfreegen);
+    Sforeign_symbol("(cs)enable_object_counts", (void *)S_enable_object_counts);
+    Sforeign_symbol("(cs)set_enable_object_counts", (void *)S_set_enable_object_counts);
+    Sforeign_symbol("(cs)object_counts", (void *)S_object_counts);
+    Sforeign_symbol("(cs)unregister_guardian", (void *)S_unregister_guardian);
+    Sforeign_symbol("(cs)fire_collector", (void *)S_fire_collector);
+}
+
+static void s_instantiate_code_object(void) {
+    ptr tc = get_thread_context();
+    ptr old, cookie, proc;
+    ptr new, oldreloc, newreloc;
+    ptr pinfos;
+    uptr a, m, n;
+    iptr i, size;
+
+    old = S_get_scheme_arg(tc, 1);
+    cookie = S_get_scheme_arg(tc, 2);
+    proc = S_get_scheme_arg(tc, 3);
+
+    tc_mutex_acquire()
+    new = S_code(tc, CODETYPE(old), CODELEN(old));
+    tc_mutex_release()
+
+    oldreloc = CODERELOC(old);
+    size = RELOCSIZE(oldreloc);
+    newreloc = S_relocation_table(size);
+    RELOCCODE(newreloc) = new;
+    for (i = 0; i < size; i += 1) RELOCIT(newreloc, i) = RELOCIT(oldreloc, i);
+
+    CODERELOC(new) = newreloc;
+    CODENAME(new) = CODENAME(old);
+    CODEARITYMASK(new) = CODEARITYMASK(old);
+    CODEFREE(new) = CODEFREE(old);
+    CODEINFO(new) = CODEINFO(old);
+    CODEPINFOS(new) = pinfos = CODEPINFOS(old);
+    if (pinfos != Snil) {
+      S_G.profile_counters = Scons(S_weak_cons(new, pinfos), S_G.profile_counters);
+    }
+
+    for (i = 0; i < CODELEN(old); i++) CODEIT(new,i) = CODEIT(old,i);
+
+    m = RELOCSIZE(newreloc);
+    a = 0;
+    n = 0;
+    while (n < m) {
+        uptr entry, item_off, code_off; ptr obj;
+        entry = RELOCIT(newreloc, n); n += 1;
+        if (RELOC_EXTENDED_FORMAT(entry)) {
+            item_off = RELOCIT(newreloc, n); n += 1;
+            code_off = RELOCIT(newreloc, n); n += 1;
+        } else {
+            item_off = RELOC_ITEM_OFFSET(entry);
+            code_off = RELOC_CODE_OFFSET(entry);
+        }
+        a += code_off;
+        obj = S_get_code_obj(RELOC_TYPE(entry), old, a, item_off);
+
+      /* we've seen the enemy, and he is us */
+        if (obj == old) obj = new;
+
+      /* if we find our cookie, insert proc; otherwise, insert the object
+         into new to get proper adjustment of relative addresses */
+        if (obj == cookie)
+           S_set_code_obj("fcallable", RELOC_TYPE(entry), new, a, proc, item_off);
+        else
+           S_set_code_obj("fcallable", RELOC_TYPE(entry), new, a, obj, item_off);
+    }
+    S_flush_instruction_cache(tc);
+
+    AC0(tc) = new;
+}
+
+static void s_link_code_object(ptr co, ptr objs) {
+    ptr t; uptr a, m, n;
+
+    t = CODERELOC(co);
+    m = RELOCSIZE(t);
+    a = 0;
+    n = 0;
+    while (n < m) {
+        uptr entry, item_off, code_off;
+        entry = RELOCIT(t, n); n += 1;
+        if (RELOC_EXTENDED_FORMAT(entry)) {
+            item_off = RELOCIT(t, n); n += 1;
+            code_off = RELOCIT(t, n); n += 1;
+        } else {
+            item_off = RELOC_ITEM_OFFSET(entry);
+            code_off = RELOC_CODE_OFFSET(entry);
+        }
+        a += code_off;
+        S_set_code_obj("gc", RELOC_TYPE(entry), co, a, Scar(objs), item_off);
+        objs = Scdr(objs);
+    }
+}
+
+static INT s_check_heap_enabledp(void) {
+  return S_checkheap;
+}
+
+static void s_enable_check_heap(IBOOL b) {
+  S_checkheap = b;
+}
+
+static uptr s_check_heap_errors(void) {
+  return S_checkheap_errors;
+}

ta6ob/c/print.c

@@ -0,0 +1,288 @@
+/* print.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+/* locally defined functions */
+static void pimmediate(ptr x);
+static void pbox(ptr x);
+static void pclo(ptr x);
+static void pcode(ptr x);
+static void pcons(ptr x);
+static void pfile(ptr x);
+static void pinexactnum(ptr x);
+static IBOOL exact_real_negativep(ptr x);
+static void pexactnum(ptr x);
+static void prat(ptr x);
+static void pchar(ptr x);
+static void pstr(ptr x);
+static void psym(ptr x);
+static void pvec(ptr x);
+static void pfxvector(ptr x);
+static void pbytevector(ptr x);
+static void pflonum(ptr x);
+static void pfixnum(ptr x);
+static void pbignum(ptr x);
+static void wrint(ptr x);
+
+void S_print_init(void) {}
+
+void S_prin1(ptr x) {
+    if (Simmediatep(x)) pimmediate(x);
+    else if (Spairp(x)) pcons(x);
+    else if (Ssymbolp(x)) psym(x);
+    else if (Sfixnump(x)) pfixnum(x);
+    else if (Sbignump(x)) pbignum(x);
+    else if (Sstringp(x)) pstr(x);
+    else if (Sratnump(x)) prat(x);
+    else if (Sflonump(x)) (void) pflonum(x);
+    else if (Sinexactnump(x)) pinexactnum(x);
+    else if (Sexactnump(x)) pexactnum(x);
+    else if (Svectorp(x)) pvec(x);
+    else if (Sfxvectorp(x)) pfxvector(x);
+    else if (Sbytevectorp(x)) pbytevector(x);
+    else if (Sboxp(x)) pbox(x);
+    else if (Sprocedurep(x)) pclo(x);
+    else if (Scodep(x)) pcode(x);
+    else if (Sportp(x)) pfile(x);
+    else if (Srecordp(x)) printf("#<record>");
+    else printf("#<garbage>");
+    fflush(stdout);
+}
+
+
+static void pimmediate(ptr x) {
+    if (Scharp(x)) pchar(x);
+    else if (x == Snil) printf("()");
+    else if (x == Strue) printf("#t");
+    else if (x == Sfalse) printf("#f");
+    else if (x == Seof_object) printf("#!eof");
+    else if (x == Sbwp_object) printf("#!bwp");
+    else if (x == sunbound) printf("#<unbound>");
+    else if (x == Svoid) printf("#<void>");
+    else printf("#<garbage>");
+}
+
+static void pbox(ptr x) {
+    printf("#&");
+    S_prin1(Sunbox(x));
+}
+
+static void pclo(UNUSED ptr x) {
+  if (CODETYPE(CLOSCODE(x)) & (code_flag_continuation << code_flags_offset))
+    printf("#<continuation>");
+  else
+    printf("#<procedure>");
+}
+
+static void pcode(UNUSED ptr x) {
+    printf("#<code>");
+}
+
+static void pcons(ptr x) {
+    putchar('(');
+    while (1) {
+        S_prin1(Scar(x));
+        x = Scdr(x);
+        if (!Spairp(x)) break;
+        putchar(' ');
+    }
+    if (x!=Snil) {
+        printf(" . ");
+        S_prin1(x);
+    }
+    putchar(')');
+}
+
+
+static void pfile(UNUSED ptr x) {
+    printf("#<port>");
+}
+
+static void pinexactnum(ptr x) {
+    S_prin1(TYPE(&INEXACTNUM_REAL_PART(x),type_flonum));
+    if (INEXACTNUM_IMAG_PART(x) >= 0.0) putchar('+');
+    S_prin1(TYPE(&INEXACTNUM_IMAG_PART(x),type_flonum));
+    putchar('i');
+}
+
+static IBOOL exact_real_negativep(ptr x) {
+  if (Sratnump(x)) x = RATNUM(x);
+  return Sfixnump(x) ? UNFIX(x) < 0 : BIGSIGN(x);
+}
+
+static void pexactnum(ptr x) {
+    S_prin1(EXACTNUM_REAL_PART(x));
+    if (!exact_real_negativep(EXACTNUM_IMAG_PART(x))) putchar('+');
+    S_prin1(EXACTNUM_IMAG_PART(x));
+    putchar('i');
+}
+
+static void prat(ptr x) {
+    wrint(RATNUM(x));
+    putchar('/');
+    wrint(RATDEN(x));
+}
+
+static void pchar(ptr x) {
+  int k = Schar_value(x);
+  if (k >= 256) k = '?';
+  printf("#\\");
+  putchar(k);
+}
+
+static void pstr(ptr x) {
+  iptr i, n = Sstring_length(x);
+
+  putchar('"');
+  for (i = 0; i < n; i += 1) {
+    int k = Sstring_ref(x, i);
+    if (k >= 256) k = '?';
+    if ((k == '\\') || (k == '"')) putchar('\\');
+    putchar(k);
+  }
+  putchar('"');
+}
+
+static void display_string(ptr x) {
+  iptr i, n = Sstring_length(x);
+
+  for (i = 0; i < n; i += 1) {
+    int k = Sstring_ref(x, i);
+    if (k >= 256) k = '?';
+    putchar(k);
+  }
+}
+
+static void psym(ptr x) {
+  ptr name = SYMNAME(x);
+  if (Sstringp(name)) {
+    display_string(name);
+  } else if (Spairp(name)) {
+    if (Scar(name) != Sfalse) {
+      printf("#{");
+      display_string(Scdr(name));
+      printf(" ");
+      display_string(Scar(name));
+      printf("}");
+    } else {
+      printf("#<gensym ");
+      display_string(Scdr(name));
+      printf(">");
+    }
+  } else {
+    printf("#<gensym>");
+  }
+}
+
+static void pvec(ptr x) {
+    iptr n;
+
+    putchar('#');
+    n = Svector_length(x);
+    wrint(FIX(n));
+    putchar('(');
+    if (n != 0) {
+        iptr i = 0;
+
+        while (1) {
+            S_prin1(Svector_ref(x, i));
+            if (++i == n) break;
+            putchar(' ');
+        }
+    }
+    putchar(')');
+}
+
+static void pfxvector(ptr x) {
+    iptr n;
+
+    putchar('#');
+    n = Sfxvector_length(x);
+    wrint(FIX(n));
+    printf("vfx(");
+    if (n != 0) {
+        iptr i = 0;
+
+        while (1) {
+            pfixnum(Sfxvector_ref(x, i));
+            if (++i == n) break;
+            putchar(' ');
+        }
+    }
+    putchar(')');
+}
+
+static void pbytevector(ptr x) {
+    iptr n;
+
+    putchar('#');
+    n = Sbytevector_length(x);
+    wrint(FIX(n));
+    printf("vu8(");
+    if (n != 0) {
+        iptr i = 0;
+
+        while (1) {
+            pfixnum(FIX(Sbytevector_u8_ref(x, i)));
+            if (++i == n) break;
+            putchar(' ');
+        }
+    }
+    putchar(')');
+}
+
+static void pflonum(ptr x) {
+  char buf[256], *s;
+
+ /* use snprintf to get it in a string */
+  (void) snprintf(buf, 256, "%.16g",FLODAT(x));
+
+ /* print the silly thing */
+  printf("%s", buf);
+
+ /* add .0 if it looks like an integer */
+  s = buf;
+  while (*s != 'E' && *s != 'e' && *s != '.')
+    if (*s++ == 0) {
+      printf(".0");
+      break;
+    }
+}
+
+static void pfixnum(ptr x) {
+  if (UNFIX(x) < 0) {
+    putchar('-');
+    x = S_sub(FIX(0), x);
+  }
+  wrint(x);
+}
+
+static void pbignum(ptr x) {
+  if (BIGSIGN(x)) {
+    putchar('-');
+    x = S_sub(FIX(0), x);
+  }
+  wrint(x);
+}
+
+static void wrint(ptr x) {
+  ptr q, r;
+
+  S_trunc_rem(get_thread_context(), x, FIX(10), &q, &r);
+  if (q != 0) wrint(q);
+  putchar((INT)UNFIX(r) + '0');
+}

ta6ob/c/schlib.c

@@ -0,0 +1,307 @@
+/* schlib.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+/* locally defined functions */
+static ptr S_call(ptr tc, ptr cp, iptr argcnt);
+
+/* Sinteger_value is in number.c */
+
+/* Sinteger32_value is in number.c */
+
+/* Sinteger64_value is in number.c */
+
+void Sset_box(ptr x, ptr y) {
+    SETBOXREF(x, y);
+}
+
+void Sset_car(ptr x, ptr y) {
+    SETCAR(x, y);
+}
+
+void Sset_cdr(ptr x, ptr y) {
+    SETCDR(x, y);
+}
+
+void Svector_set(ptr x, iptr i, ptr y) {
+    SETVECTIT(x, i, y);
+}
+
+/* Scons is in alloc.c */
+
+ptr Sstring_to_symbol(const char *s) {
+    return S_intern((const unsigned char *)s);
+}
+
+ptr Ssymbol_to_string(ptr x) {
+  ptr name = SYMNAME(x);
+  if (Sstringp(name))
+    return name;
+  else if (Spairp(name))
+    return Scdr(name);
+  else
+   /* don't have access to prefix or count, and can't handle arbitrary
+      prefixes anyway, so always punt */
+    return S_string("gensym", -1);
+}
+
+/* Sflonum is in alloc.c */
+
+ptr Smake_vector(iptr n, ptr x) {
+    ptr p; iptr i;
+
+    p = S_vector(n);
+    for (i = 0; i < n; i += 1) INITVECTIT(p, i) = x;
+    return p;
+}
+
+ptr Smake_fxvector(iptr n, ptr x) {
+    ptr p; iptr i;
+
+    p = S_fxvector(n);
+    for (i = 0; i < n; i += 1) Sfxvector_set(p, i, x);
+    return p;
+}
+
+ptr Smake_bytevector(iptr n, int x) {
+    ptr p; iptr i;
+
+    p = S_bytevector(n);
+    for (i = 0; i < n; i += 1) Sbytevector_u8_set(p, i, (octet)x);
+    return p;
+}
+
+ptr Smake_string(iptr n, int c) {
+    ptr p; iptr i;
+
+    p = S_string((char *)NULL, n);
+    for (i = 0; i < n; i += 1) Sstring_set(p, i, c);
+    return p;
+}
+
+ptr Smake_uninitialized_string(iptr n) {
+    return S_string((char *)NULL, n);
+}
+
+ptr Sstring(const char *s) {
+    return S_string(s, -1);
+}
+
+ptr Sstring_of_length(const char *s, iptr n) {
+    return S_string(s, n);
+}
+
+/* Sstring_utf8 is in alloc.c */
+
+/* Sbox is in alloc.c */
+
+/* Sinteger is in number.c */
+
+/* Sunsigned is in number.c */
+
+/* Sunsigned32 is in number.c */
+
+/* Sunsigned64 is in number.c */
+
+ptr Stop_level_value(ptr x) {
+  ptr tc = get_thread_context();
+  IBOOL enabled = (DISABLECOUNT(tc) == 0);
+  if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) + 1);
+  x = Scall1(S_symbol_value(Sstring_to_symbol("$c-tlv")), x);
+  if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) - 1);
+  return x;
+}
+
+void Sset_top_level_value(ptr x, ptr y) {
+  ptr tc = get_thread_context();
+  IBOOL enabled = (DISABLECOUNT(tc) == 0);
+  if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) + 1);
+  Scall2(S_symbol_value(Sstring_to_symbol("$c-stlv!")), x, y);
+  if (enabled) DISABLECOUNT(tc) = FIX(UNFIX(DISABLECOUNT(tc)) - 1);
+}
+
+#include <setjmp.h>
+
+/* consider rewriting these to avoid multiple calls to get_thread_context */
+ptr Scall0(ptr cp) {
+    ptr tc = get_thread_context();
+    S_initframe(tc,0);
+    return S_call(tc, cp, 0);
+}
+
+ptr Scall1(ptr cp, ptr x1) {
+    ptr tc = get_thread_context();
+    S_initframe(tc, 1);
+    S_put_arg(tc, 1, x1);
+    return S_call(tc, cp, 1);
+}
+
+ptr Scall2(ptr cp, ptr x1, ptr x2) {
+    ptr tc = get_thread_context();
+    S_initframe(tc, 2);
+    S_put_arg(tc, 1, x1);
+    S_put_arg(tc, 2, x2);
+    return S_call(tc, cp, 2);
+}
+
+ptr Scall3(ptr cp, ptr x1, ptr x2, ptr x3) {
+    ptr tc = get_thread_context();
+    S_initframe(tc, 3);
+    S_put_arg(tc, 1, x1);
+    S_put_arg(tc, 2, x2);
+    S_put_arg(tc, 3, x3);
+    return S_call(tc, cp, 3);
+}
+
+void Sinitframe(iptr n) {
+    ptr tc = get_thread_context();
+    S_initframe(tc, n);
+}
+
+void S_initframe(ptr tc, iptr n) {
+  /* check for and handle stack overflow */
+    if ((ptr *)SFP(tc) + n + 2 > (ptr *)ESP(tc))
+        S_overflow(tc, (n+2)*sizeof(ptr));
+
+  /* intermediate frame contains old RA + cchain */;
+    SFP(tc) = (ptr)((ptr *)SFP(tc) + 2);
+}
+
+void Sput_arg(iptr i, ptr x) {
+    ptr tc = get_thread_context();
+    S_put_arg(tc, i, x);
+}
+
+void S_put_arg(ptr tc, iptr i, ptr x) {
+    if (i <= asm_arg_reg_cnt)
+        REGARG(tc, i) = x;
+    else
+        FRAME(tc, i - asm_arg_reg_cnt) = x;
+}
+
+ptr Scall(ptr cp, iptr argcnt) {
+    ptr tc = get_thread_context();
+    return S_call(tc, cp, argcnt);
+}
+
+static ptr S_call(ptr tc, ptr cp, iptr argcnt) {
+    AC0(tc) = (ptr)argcnt;
+    AC1(tc) = cp;
+    S_call_help(tc, 1, 0);
+    return AC0(tc);
+}
+
+/* args are set up, argcnt in ac0, closure in ac1 */
+void S_call_help(ptr tc_in, IBOOL singlep, IBOOL lock_ts) {
+  /* declaring code and tc volatile should be unnecessary, but it quiets gcc
+     and avoids occasional invalid memory violations on Windows */
+  void *jb; volatile ptr code;
+  volatile ptr tc = tc_in;
+
+  /* lock caller's code object, since his return address is sitting in
+     the C stack and we may end up in a garbage collection */
+    code = CP(tc);
+    if (Sprocedurep(code)) code = CLOSCODE(code);
+    if (!IMMEDIATE(code) && !Scodep(code))
+      S_error_abort("S_call_help: invalid code pointer");
+    Slock_object(code);
+
+    CP(tc) = AC1(tc);
+
+    jb = CREATEJMPBUF();
+    if (jb == NULL)
+      S_error_abort("unable to allocate memory for jump buffer");
+    if (lock_ts) {
+      /* Lock a code object passed in TS, which is a more immediate
+         caller whose return address is on the C stack */
+      Slock_object(TS(tc));
+      CCHAIN(tc) = Scons(Scons(jb, Scons(code,TS(tc))), CCHAIN(tc));
+    } else {
+      CCHAIN(tc) = Scons(Scons(jb, Scons(code,Sfalse)), CCHAIN(tc));
+    }
+
+    FRAME(tc, -1) = CCHAIN(tc);
+
+    switch (SETJMP(jb)) {
+        case 0: /* first time */
+            S_generic_invoke(tc, S_G.invoke_code_object);
+            S_error_abort("S_generic_invoke return");
+            break;
+        case -1: /* error */
+            S_generic_invoke(tc, S_G.error_invoke_code_object);
+            S_error_abort("S_generic_invoke return");
+            break;
+        case 1: { /* normal return */
+            ptr yp = CCHAIN(tc);
+            FREEJMPBUF(CAAR(yp));
+            CCHAIN(tc) = Scdr(yp);
+            break;
+        }
+        default:
+            S_error_abort("unexpected SETJMP return value");
+            break;
+    }
+
+  /* verify single return value */
+    if (singlep && (iptr)AC1(tc) != 1)
+        S_error1("", "returned ~s values to single value return context",
+                   FIX((iptr)AC1(tc)));
+
+  /* restore caller to cp so that we can lock it again another day.  we
+     restore the code object rather than the original closure, as the
+     closure may have been relocated or reclaimed by now */
+    CP(tc) = code;
+}
+
+void S_call_one_result(void) {
+    ptr tc = get_thread_context();
+    S_call_help(tc, 1, 1);
+}
+
+void S_call_any_results(void) {
+    ptr tc = get_thread_context();
+    S_call_help(tc, 0, 1);
+}
+
+/* cchain = ((jb . (co . maybe-co)) ...) */
+void S_return(void) {
+    ptr tc = get_thread_context();
+    ptr xp, yp;
+
+    SFP(tc) = (ptr)((ptr *)SFP(tc) - 2);
+
+  /* grab saved cchain */
+    yp = FRAME(tc, 1);
+
+  /* verify saved cchain is sublist of current cchain */
+    for (xp = CCHAIN(tc); xp != yp; xp = Scdr(xp))
+        if (xp == Snil)
+            S_error("", "attempt to return to stale foreign context");
+
+  /* error checks are done; now unlock affected code objects */
+    for (xp = CCHAIN(tc); ; xp = Scdr(xp)) {
+        ptr p = CDAR(xp);
+        Sunlock_object(Scar(p));
+        if (Scdr(p) != Sfalse) Sunlock_object(Scdr(p));
+        if (xp == yp) break;
+        FREEJMPBUF(CAAR(xp));
+    }
+
+  /* reset cchain and return via longjmp */
+    CCHAIN(tc) = yp;
+    LONGJMP(CAAR(yp), 1);
+}

ta6ob/c/schsig.c

@@ -0,0 +1,783 @@
+/* schsig.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+#include <setjmp.h>
+
+/* locally defined functions */
+static void S_promote_to_multishot(ptr k);
+static void split(ptr k, ptr *s);
+static void reset_scheme(void);
+static NORETURN void do_error(iptr type, const char *who, const char *s, ptr args);
+static void handle_call_error(ptr tc, iptr type, ptr x);
+static void init_signal_handlers(void);
+static void keyboard_interrupt(ptr tc);
+
+ptr S_get_scheme_arg(ptr tc, iptr n) {
+
+    if (n <= asm_arg_reg_cnt) return REGARG(tc, n);
+    else return FRAME(tc, n - asm_arg_reg_cnt);
+}
+
+void S_put_scheme_arg(ptr tc, iptr n, ptr x) {
+
+    if (n <= asm_arg_reg_cnt) REGARG(tc, n) = x;
+    else FRAME(tc, n - asm_arg_reg_cnt) = x;
+}
+
+static void S_promote_to_multishot(ptr k) {
+    while (CONTLENGTH(k) != CONTCLENGTH(k)) {
+        CONTLENGTH(k) = CONTCLENGTH(k);
+        k = CONTLINK(k);
+    }
+}
+
+/* k must be is a multi-shot continuation, and s (the split point)
+ * must be strictly between the base and end of k's stack segment. */
+static void split(ptr k, ptr *s) {
+    iptr m, n;
+    seginfo *si;
+
+    tc_mutex_acquire()
+  /* set m to size of lower piece, n to size of upper piece */
+    m = (uptr)s - (uptr)CONTSTACK(k);
+    n = CONTCLENGTH(k) - m;
+
+    si = SegInfo(ptr_get_segment(k));
+  /* insert a new continuation between k and link(k) */
+    CONTLINK(k) = S_mkcontinuation(si->space,
+                                 si->generation,
+                                 CLOSENTRY(k),
+                                 CONTSTACK(k),
+                                 m, m,
+                                 CONTLINK(k),
+                                 *s,
+                                 Snil);
+    CONTLENGTH(k) = CONTCLENGTH(k) = n;
+    CONTSTACK(k) = (ptr)s;
+    *s = (ptr)DOUNDERFLOW;
+    tc_mutex_release()
+}
+
+/* We may come in to S_split_and_resize with a multi-shot continuation whose
+ * stack segment exceeds the copy bound or is too large to fit along
+ * with the return values in the current stack.  We may also come in to
+ * S_split_and_resize with a one-shot continuation for which all of the
+ * above is true and for which there is insufficient space between the
+ * top frame and the end of the stack.  If we have to split a 1-shot, we
+ * promote it to multi-shot; doing otherwise is too much trouble.  */
+void S_split_and_resize(void) {
+    ptr tc = get_thread_context();
+    ptr k; iptr value_count; iptr n;
+
+  /* cp = continuation, ac0 = return value count */
+    k = CP(tc);
+    value_count = (iptr)AC0(tc);
+
+    if (CONTCLENGTH(k) > underflow_limit) {
+        iptr frame_size;
+        ptr *front_stack_ptr, *end_stack_ptr, *split_point, *guard;
+
+        front_stack_ptr = (ptr *)CONTSTACK(k);
+        end_stack_ptr = (ptr *)((uptr)front_stack_ptr + CONTCLENGTH(k));
+
+        guard = (ptr *)((uptr)end_stack_ptr - underflow_limit);
+
+      /* set split point to base of top frame */
+        frame_size = ENTRYFRAMESIZE(CONTRET(k));
+        split_point = (ptr *)((uptr)end_stack_ptr - frame_size);
+
+      /* split only if we have more than one frame */
+        if (split_point != front_stack_ptr) {
+          /* walk the stack to set split_point at first frame above guard */
+          /* note that first frame may have put us below the guard already */
+            for (;;) {
+                ptr *p;
+                frame_size = ENTRYFRAMESIZE(*split_point);
+                p = (ptr *)((uptr)split_point - frame_size);
+                if (p < guard) break;
+                split_point = p;
+            }
+
+          /* promote to multi-shot if necessary */
+            S_promote_to_multishot(k);
+
+          /* split */
+            split(k, split_point);
+        }
+    }
+
+  /* make sure the stack is big enough to hold continuation
+   * this is conservative: really need stack-base + clength <= esp
+   * and clength + size(values) < stack-size; also, size may include
+   * argument register values */
+    n = CONTCLENGTH(k) + (value_count * sizeof(ptr)) + stack_slop;
+    if (n >= SCHEMESTACKSIZE(tc)) {
+       tc_mutex_acquire()
+       S_reset_scheme_stack(tc, n);
+       tc_mutex_release()
+    }
+}
+
+iptr S_continuation_depth(ptr k) {
+    iptr n, frame_size; ptr *stack_base, *stack_ptr;
+
+    n = 0;
+  /* terminate on shot 1-shot, which could be null_continuation */
+    while (CONTLENGTH(k) != scaled_shot_1_shot_flag) {
+        stack_base = (ptr *)CONTSTACK(k);
+        frame_size = ENTRYFRAMESIZE(CONTRET(k));
+        stack_ptr = (ptr *)((uptr)stack_base + CONTCLENGTH(k));
+        for (;;) {
+            stack_ptr = (ptr *)((uptr)stack_ptr - frame_size);
+            n += 1;
+            if (stack_ptr == stack_base) break;
+            frame_size = ENTRYFRAMESIZE(*stack_ptr);
+        }
+        k = CONTLINK(k);
+    }
+    return n;
+}
+
+ptr S_single_continuation(ptr k, iptr n) {
+    iptr frame_size; ptr *stack_base, *stack_top, *stack_ptr;
+
+  /* bug out on shot 1-shots, which could be null_continuation */
+    while (CONTLENGTH(k) != scaled_shot_1_shot_flag) {
+        stack_base = (ptr *)CONTSTACK(k);
+        stack_top = (ptr *)((uptr)stack_base + CONTCLENGTH(k));
+        stack_ptr = stack_top;
+        frame_size = ENTRYFRAMESIZE(CONTRET(k));
+        for (;;) {
+            if (n == 0) {
+              /* promote to multi-shot if necessary, even if we don't end
+               * up in split, since inspector assumes multi-shot */
+                S_promote_to_multishot(k);
+
+                if (stack_ptr != stack_top) {
+                    split(k, stack_ptr);
+                    k = CONTLINK(k);
+                }
+
+                stack_ptr = (ptr *)((uptr)stack_ptr - frame_size);
+                if (stack_ptr != stack_base)
+                    split(k, stack_ptr);
+
+                return k;
+            } else {
+                n -= 1;
+                stack_ptr = (ptr *)((uptr)stack_ptr - frame_size);
+                if (stack_ptr == stack_base) break;
+                frame_size = ENTRYFRAMESIZE(*stack_ptr);
+            }
+        }
+        k = CONTLINK(k);
+    }
+
+    return Sfalse;
+}
+
+void S_handle_overflow(void) {
+    ptr tc = get_thread_context();
+
+ /* default frame size is enough */
+    S_overflow(tc, 0);
+}
+
+void S_handle_overflood(void) {
+    ptr tc = get_thread_context();
+
+ /* xp points to where esp needs to be */
+    S_overflow(tc, ((ptr *)XP(tc) - (ptr *)SFP(tc))*sizeof(ptr));
+}
+
+void S_handle_apply_overflood(void) {
+    ptr tc = get_thread_context();
+
+ /* ac0 contains the argument count for the called procedure */
+ /* could reduce request by default frame size and number of arg registers */
+ /* the "+ 1" is for the return address slot */
+    S_overflow(tc, ((iptr)AC0(tc) + 1) * sizeof(ptr));
+}
+
+/* allocates a new stack
+ * --the old stack below the sfp is turned into a continuation
+ * --the old stack above the sfp is copied to the new stack
+ * --return address must be in first frame location
+ * --scheme registers are preserved or reset
+ * frame_request is how much (in bytes) to increase the default frame size
+ */
+void S_overflow(ptr tc, iptr frame_request) {
+    ptr *sfp;
+    iptr above_split_size, sfp_offset;
+    ptr *split_point, *guard, *other_guard;
+    iptr split_stack_length, split_stack_clength;
+    ptr nuate;
+
+    sfp = (ptr *)SFP(tc);
+    nuate = SYMVAL(S_G.nuate_id);
+    if (!Scodep(nuate)) {
+        S_error_abort("overflow: nuate not yet defined");
+    }
+
+    guard = (ptr *)((uptr)sfp - underflow_limit);
+  /* leave at least stack_slop headroom in the old stack to reduce the need for return-point overflow checks */
+    other_guard = (ptr *)((uptr)SCHEMESTACK(tc) + (uptr)SCHEMESTACKSIZE(tc) - (uptr)stack_slop);
+    if ((uptr)other_guard < (uptr)guard) guard = other_guard;
+
+  /* split only if old stack contains more than underflow_limit bytes */
+    if (guard > (ptr *)SCHEMESTACK(tc)) {
+        iptr frame_size;
+
+      /* set split point to base of the frame below the current one */
+        frame_size = ENTRYFRAMESIZE(*sfp);
+        split_point = (ptr *)((uptr)sfp - frame_size);
+
+      /* split only if we have more than one frame */
+        if (split_point != (ptr *)SCHEMESTACK(tc)) {
+          /* walk the stack to set split_point at first frame above guard */
+          /* note that first frame may have put us below the guard already */
+            for (;;) {
+                ptr *p;
+
+                frame_size = ENTRYFRAMESIZE(*split_point);
+                p = (ptr *)((uptr)split_point - frame_size);
+                if (p < guard) break;
+                split_point = p;
+            }
+
+            split_stack_clength = (uptr)split_point - (uptr)SCHEMESTACK(tc);
+
+          /* promote to multi-shot if current stack is shrimpy */
+            if (SCHEMESTACKSIZE(tc) < default_stack_size / 4) {
+                split_stack_length = split_stack_clength;
+                S_promote_to_multishot(STACKLINK(tc));
+            } else {
+                split_stack_length = SCHEMESTACKSIZE(tc);
+            }
+
+          /* create a continuation */
+            tc_mutex_acquire()
+            STACKLINK(tc) = S_mkcontinuation(space_new,
+                                        0,
+                                        CODEENTRYPOINT(nuate),
+                                        SCHEMESTACK(tc),
+                                        split_stack_length,
+                                        split_stack_clength,
+                                        STACKLINK(tc),
+                                        *split_point,
+                                        Snil);
+            tc_mutex_release()
+
+          /* overwrite old return address with dounderflow */
+            *split_point = (ptr)DOUNDERFLOW;
+        }
+    } else {
+        split_point = (ptr *)SCHEMESTACK(tc);
+    }
+
+    above_split_size = SCHEMESTACKSIZE(tc) - ((uptr)split_point - (uptr)SCHEMESTACK(tc));
+
+  /* allocate a new stack, retaining same relative sfp */
+    sfp_offset = (uptr)sfp - (uptr)split_point;
+    tc_mutex_acquire()
+    S_reset_scheme_stack(tc, above_split_size + frame_request);
+    tc_mutex_release()
+    SFP(tc) = (ptr)((uptr)SCHEMESTACK(tc) + sfp_offset);
+
+  /* copy up everything above the split point.  we don't know where the
+     current frame ends, so we copy through the end of the old stack */
+    {ptr *p, *q; iptr n;
+     p = (ptr *)SCHEMESTACK(tc);
+     q = split_point;
+     for (n = above_split_size; n != 0; n -= sizeof(ptr)) *p++ = *q++;
+    }
+}
+
+void S_error_abort(const char *s) {
+    fprintf(stderr, "%s\n", s);
+    S_abnormal_exit();
+}
+
+void S_abnormal_exit(void) {
+  S_abnormal_exit_proc();
+  fprintf(stderr, "abnormal_exit procedure did not exit\n");
+  exit(1);
+}
+
+static void reset_scheme(void) {
+    ptr tc = get_thread_context();
+
+    tc_mutex_acquire()
+   /* eap should always be up-to-date now that we write-through to the tc
+      when making any changes to eap when eap is a real register */
+    S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc));
+    S_reset_allocation_pointer(tc);
+    S_reset_scheme_stack(tc, stack_slop);
+    FRAME(tc,0) = (ptr)DOUNDERFLOW;
+    tc_mutex_release()
+}
+
+/* error_resets occur with the system in an unknown state,
+ * thus we must reset with no opportunity for debugging
+ */
+
+void S_error_reset(const char *s) {
+
+    if (!S_errors_to_console) reset_scheme();
+    do_error(ERROR_RESET, "", s, Snil);
+}
+
+void S_error(const char *who, const char *s) {
+    do_error(ERROR_OTHER, who, s, Snil);
+}
+
+void S_error1(const char *who, const char *s, ptr x) {
+    do_error(ERROR_OTHER, who, s, LIST1(x));
+}
+
+void S_error2(const char *who, const char *s, ptr x, ptr y) {
+    do_error(ERROR_OTHER, who, s, LIST2(x,y));
+}
+
+void S_error3(const char *who, const char *s, ptr x, ptr y, ptr z) {
+    do_error(ERROR_OTHER, who, s, LIST3(x,y,z));
+}
+
+void S_boot_error(ptr who, ptr msg, ptr args) {
+  printf("error caught before error-handing subsystem initialized\n"); 
+  printf("who: ");
+  S_prin1(who);
+  printf("\nmsg: ");
+  S_prin1(msg);
+  printf("\nargs: ");
+  S_prin1(args);
+  printf("\n");
+  fflush(stdout);
+  S_abnormal_exit();
+}
+
+static void do_error(iptr type, const char *who, const char *s, ptr args) {
+    ptr tc = get_thread_context();
+
+    if (S_errors_to_console || tc == (ptr)0 || CCHAIN(tc) == Snil) {
+        if (strlen(who) == 0)
+          printf("Error: %s\n", s);
+        else
+          printf("Error in %s: %s\n", who, s);
+        S_prin1(args); putchar('\n');
+        fflush(stdout);
+        S_abnormal_exit();
+    }
+
+    args = Scons(FIX(type),
+                 Scons((strlen(who) == 0 ? Sfalse : Sstring_utf8(who,-1)),
+                       Scons(Sstring_utf8(s, -1), args)));
+
+#ifdef PTHREADS
+    while (S_tc_mutex_depth > 0) {
+      S_mutex_release(&S_tc_mutex);
+      S_tc_mutex_depth -= 1;
+    }
+#endif /* PTHREADS */
+    
+    TRAP(tc) = (ptr)1;
+    AC0(tc) = (ptr)1;
+    CP(tc) = S_symbol_value(S_G.error_id);
+    S_put_scheme_arg(tc, 1, args);
+    LONGJMP(CAAR(CCHAIN(tc)), -1);
+}
+
+static void handle_call_error(ptr tc, iptr type, ptr x) {
+    ptr p, arg1;
+    iptr argcnt;
+
+    argcnt = (iptr)AC0(tc);
+    arg1 = argcnt == 0 ? Snil : S_get_scheme_arg(tc, 1);
+    p = Scons(FIX(type), Scons(FIX(argcnt), Scons(x, Scons(arg1, Snil))));
+
+    if (S_errors_to_console) {
+        printf("Call error: ");
+        S_prin1(p); putchar('\n'); fflush(stdout);
+        S_abnormal_exit();
+    }
+
+    CP(tc) = S_symbol_value(S_G.error_id);
+    S_put_scheme_arg(tc, 1, p);
+    AC0(tc) = (ptr)(argcnt==0 ? 1 : argcnt);
+    TRAP(tc) = (ptr)1;         /* Why is this here? */
+}
+
+void S_handle_docall_error(void) {
+    ptr tc = get_thread_context();
+
+    handle_call_error(tc, ERROR_CALL_NONPROCEDURE, CP(tc));
+}
+
+void S_handle_arg_error(void) {
+    ptr tc = get_thread_context();
+
+    handle_call_error(tc, ERROR_CALL_ARGUMENT_COUNT, CP(tc));
+}
+
+void S_handle_nonprocedure_symbol(void) {
+    ptr tc = get_thread_context();
+    ptr s;
+
+    s = XP(tc);
+    handle_call_error(tc,
+                      (SYMVAL(s) == sunbound ?
+                                ERROR_CALL_UNBOUND :
+                                ERROR_CALL_NONPROCEDURE_SYMBOL),
+                      s);
+}
+
+void S_handle_values_error(void) {
+    ptr tc = get_thread_context();
+
+    handle_call_error(tc, ERROR_VALUES, Sfalse);
+}
+
+void S_handle_mvlet_error(void) {
+    ptr tc = get_thread_context();
+
+    handle_call_error(tc, ERROR_MVLET, Sfalse);
+}
+
+static void keyboard_interrupt(ptr tc) {
+  KEYBOARDINTERRUPTPENDING(tc) = Strue;
+  SOMETHINGPENDING(tc) = Strue;
+}
+
+/* used in printf below
+static uptr list_length(ptr ls) {
+  uptr i = 0;
+  while (ls != Snil) { ls = Scdr(ls); i += 1; }
+  return i;
+}
+*/
+
+void S_fire_collector(void) {
+  ptr crp_id = S_G.collect_request_pending_id;
+
+/*  printf("firing collector!\n"); fflush(stdout); */
+
+  if (!Sboolean_value(S_symbol_value(crp_id))) {
+    ptr ls;
+
+/*    printf("really firing collector!\n"); fflush(stdout); */
+
+    tc_mutex_acquire()
+   /* check again in case some other thread beat us to the punch */
+    if (!Sboolean_value(S_symbol_value(crp_id))) {
+/* printf("firing collector nthreads = %d\n", list_length(S_threads)); fflush(stdout); */
+      S_set_symbol_value(crp_id, Strue);
+      for (ls = S_threads; ls != Snil; ls = Scdr(ls))
+        SOMETHINGPENDING(THREADTC(Scar(ls))) = Strue;
+    }
+    tc_mutex_release()
+  }
+}
+
+void S_noncontinuable_interrupt(void) {
+  ptr tc = get_thread_context();
+
+  reset_scheme();
+  KEYBOARDINTERRUPTPENDING(tc) = Sfalse;
+  do_error(ERROR_NONCONTINUABLE_INTERRUPT,"","",Snil);
+}
+
+#ifdef WIN32
+ptr S_dequeue_scheme_signals(ptr tc) {
+  return Snil;
+}
+
+ptr S_allocate_scheme_signal_queue(void) {
+  return (ptr)0;
+}
+
+void S_register_scheme_signal(iptr sig) {
+  S_error("register_scheme_signal", "unsupported in this version");
+}
+
+/* code courtesy Bob Burger, burgerrg@sagian.com
+   We cannot call noncontinuable_interrupt, because we are not allowed
+   to perform a longjmp inside a signal handler; instead, we don't
+   handle the signal, which will cause the process to terminate.
+*/
+
+static BOOL WINAPI handle_signal(DWORD dwCtrlType) {
+  switch (dwCtrlType) {
+    case CTRL_C_EVENT:
+    case CTRL_BREAK_EVENT: {
+#ifdef PTHREADS
+     /* get_thread_context() always returns 0, so assume main thread */
+      ptr tc = S_G.thread_context;
+#else
+      ptr tc = get_thread_context();
+#endif
+      if (!S_pants_down && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc)))
+        return(FALSE);
+      keyboard_interrupt(tc);
+      return(TRUE);
+    }
+  }
+  return(FALSE);
+}
+
+static void init_signal_handlers(void) {
+  SetConsoleCtrlHandler(handle_signal, TRUE);
+}
+#else /* WIN32 */
+
+#include <signal.h>
+
+static void handle_signal(INT sig, siginfo_t *si, void *data);
+static IBOOL enqueue_scheme_signal(ptr tc, INT sig);
+static ptr allocate_scheme_signal_queue(void);
+static void forward_signal_to_scheme(INT sig);
+
+#define RESET_SIGNAL {\
+    sigset_t set;\
+    sigemptyset(&set);\
+    sigaddset(&set, sig);\
+    sigprocmask(SIG_UNBLOCK,&set,(sigset_t *)0);\
+}
+
+/* we buffer up to SIGNALQUEUESIZE - 1 unhandled signals, then start dropping them. */
+#define SIGNALQUEUESIZE 64
+static IBOOL scheme_signals_registered;
+
+/* we use a simple queue for pending signals.  signals are enqueued only by the
+   C signal handler and dequeued only by the Scheme event handler.  since the signal
+   handler and event handler run in the same thread, there's no need for locks
+   or write barriers. */
+
+struct signal_queue {
+  INT head;
+  INT tail;
+  INT data[SIGNALQUEUESIZE];
+};
+
+static IBOOL enqueue_scheme_signal(ptr tc, INT sig) {
+  struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc));
+  /* ignore the signal if we failed to allocate the queue */
+  if (queue == NULL) return 0;
+  INT tail = queue->tail;
+  INT next_tail = tail + 1;
+  if (next_tail == SIGNALQUEUESIZE) next_tail = 0;
+  /* ignore the signal if the queue is full */
+  if (next_tail == queue->head) return 0;
+  queue->data[tail] = sig;
+  queue->tail = next_tail;
+  return 1;
+}
+
+ptr S_dequeue_scheme_signals(ptr tc) {
+  ptr ls = Snil;
+  struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc));
+  if (queue == NULL) return ls;
+  INT head = queue->head;
+  INT tail = queue->tail;
+  INT i = tail;
+  while (i != head) {
+    if (i == 0) i = SIGNALQUEUESIZE;
+    i -= 1;
+    ls = Scons(Sfixnum(queue->data[i]), ls);
+  }
+  queue->head = tail;
+  return ls;
+}
+
+static void forward_signal_to_scheme(INT sig) {
+  ptr tc = get_thread_context();
+
+  if (enqueue_scheme_signal(tc, sig)) {
+    SIGNALINTERRUPTPENDING(tc) = Strue;
+    SOMETHINGPENDING(tc) = Strue;
+  }
+  RESET_SIGNAL
+}
+
+static ptr allocate_scheme_signal_queue(void) {
+  /* silently fail to allocate space for signals if malloc returns NULL */
+  struct signal_queue *queue = malloc(sizeof(struct signal_queue));
+  if (queue != (struct signal_queue *)0) {
+    queue->head = queue->tail = 0;
+  }
+  return (ptr)queue;
+}
+
+ptr S_allocate_scheme_signal_queue(void) {
+  return scheme_signals_registered ? allocate_scheme_signal_queue() : (ptr)0;
+}
+
+void S_register_scheme_signal(iptr sig) {
+    struct sigaction act;
+
+    tc_mutex_acquire()
+    if (!scheme_signals_registered) {
+      ptr ls;
+      scheme_signals_registered = 1;
+      for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
+        SIGNALINTERRUPTQUEUE(THREADTC(Scar(ls))) = S_allocate_scheme_signal_queue();
+      }
+    }
+    tc_mutex_release()
+
+    sigfillset(&act.sa_mask);
+    act.sa_flags = 0;
+    act.sa_handler = forward_signal_to_scheme;
+    sigaction(sig, &act, (struct sigaction *)0);
+}
+
+static void handle_signal(INT sig, UNUSED siginfo_t *si, UNUSED void *data) {
+/* printf("handle_signal(%d) for tc %x\n", sig, UNFIX(get_thread_context())); fflush(stdout); */
+  /* check for particular signals */
+    switch (sig) {
+        case SIGINT: {
+            ptr tc = get_thread_context();
+           /* disable keyboard interrupts in subordinate threads until we think
+             of something more clever to do with them */
+            if (tc == S_G.thread_context) {
+              if (!S_pants_down && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) {
+               /* this is a no-no, but the only other options are to ignore
+                  the signal or to kill the process */
+                RESET_SIGNAL
+                S_noncontinuable_interrupt();
+              }
+              keyboard_interrupt(tc);
+            }
+            RESET_SIGNAL
+            break;
+        }
+#ifdef SIGQUIT
+        case SIGQUIT:
+            RESET_SIGNAL
+            S_abnormal_exit();
+#endif /* SIGQUIT */
+        case SIGILL:
+            RESET_SIGNAL
+            S_error_reset("illegal instruction");
+        case SIGFPE:
+            RESET_SIGNAL
+            S_error_reset("arithmetic overflow");
+#ifdef SIGBUS
+        case SIGBUS:
+#endif /* SIGBUS */
+        case SIGSEGV:
+            RESET_SIGNAL
+            if (S_pants_down)
+                S_error_abort("nonrecoverable invalid memory reference");
+            else
+                S_error_reset("invalid memory reference");
+        default:
+            RESET_SIGNAL
+            S_error_reset("unexpected signal");
+    }
+}
+
+static void init_signal_handlers(void) {
+    struct sigaction act;
+
+    sigemptyset(&act.sa_mask);
+
+  /* drop pending keyboard interrupts */
+    act.sa_flags = 0;
+    act.sa_handler = SIG_IGN;
+    sigaction(SIGINT, &act, (struct sigaction *)0);
+
+  /* ignore broken pipe signals */
+    act.sa_flags = 0;
+    act.sa_handler = SIG_IGN;
+    sigaction(SIGPIPE, &act, (struct sigaction *)0);
+
+  /* set up to catch SIGINT w/no system call restart */
+#ifdef SA_INTERRUPT
+    act.sa_flags = SA_INTERRUPT|SA_SIGINFO;
+#else
+    act.sa_flags = SA_SIGINFO;
+#endif /* SA_INTERRUPT */
+    act.sa_sigaction = handle_signal;
+    sigaction(SIGINT, &act, (struct sigaction *)0);
+#ifdef BSDI
+    siginterrupt(SIGINT, 1);
+#endif
+
+  /* set up to catch selected signals */
+    act.sa_flags = SA_SIGINFO;
+    act.sa_sigaction = handle_signal;
+#ifdef SA_RESTART
+    act.sa_flags |= SA_RESTART;
+#endif /* SA_RESTART */
+#ifdef SIGQUIT
+    sigaction(SIGQUIT, &act, (struct sigaction *)0);
+#endif /* SIGQUIT */
+    sigaction(SIGILL, &act, (struct sigaction *)0);
+    sigaction(SIGFPE, &act, (struct sigaction *)0);
+#ifdef SIGBUS
+    sigaction(SIGBUS, &act, (struct sigaction *)0);
+#endif /* SIGBUS */
+    sigaction(SIGSEGV, &act, (struct sigaction *)0);
+}
+
+#endif /* WIN32 */
+
+void S_schsig_init(void) {
+    if (S_boot_time) {
+        ptr p;
+
+        S_protect(&S_G.nuate_id);
+        S_G.nuate_id = S_intern((const unsigned char *)"$nuate");
+        S_set_symbol_value(S_G.nuate_id, FIX(0));
+
+        S_protect(&S_G.null_continuation_id);
+        S_G.null_continuation_id = S_intern((const unsigned char *)"$null-continuation");
+
+        S_protect(&S_G.collect_request_pending_id);
+        S_G.collect_request_pending_id = S_intern((const unsigned char *)"$collect-request-pending");
+
+        p = S_code(get_thread_context(), type_code | (code_flag_continuation << code_flags_offset), 0);
+        CODERELOC(p) = S_relocation_table(0);
+        CODENAME(p) = Sfalse;
+        CODEARITYMASK(p) = FIX(0);
+        CODEFREE(p) = 0;
+        CODEINFO(p) = Sfalse;
+        CODEPINFOS(p) = Snil;
+
+        S_set_symbol_value(S_G.null_continuation_id,
+            S_mkcontinuation(space_new,
+                           0,
+                           CODEENTRYPOINT(p),
+                           FIX(0),
+                           scaled_shot_1_shot_flag, scaled_shot_1_shot_flag,
+                           FIX(0),
+                           FIX(0),
+                           Snil));
+
+        S_protect(&S_G.error_id);
+        S_G.error_id = S_intern((const unsigned char *)"$c-error");
+#ifndef WIN32
+        scheme_signals_registered = 0;
+#endif
+    }
+
+
+    S_pants_down = 0;
+    S_set_symbol_value(S_G.collect_request_pending_id, Sfalse);
+
+    init_signal_handlers();
+}

ta6ob/c/segment.c

@@ -0,0 +1,503 @@
+/* segment.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+/*
+Low-level Memory management strategy:
+  * use getmem-allocated multiple-segment chunks of memory
+  * maintain getmem-allocated list of chunks
+  * maintain getmem-allocated segment info and dirty vector tables
+  * after each collection, run through the list of chunks.  If all
+    segments in a chunk are empty, the chunk is a candidate for return
+    to the O/S.  Return (freemem) as many chunks as possible without going
+    below a user-defined threshold of empty segments (determined as a
+    multiple of the occupied nonstatic segments).  Bias return to the
+    most recently allocated chunks.
+  * getmem/freemem may be implemented with malloc/free; we use them
+    relatively infrequently so performance isn't an issue.
+*/
+
+#define debug(x) ;
+/* #define debug(x) {x; fflush(stdout);} */
+
+#include "system.h"
+#include "sort.h"
+#include <sys/types.h>
+
+static void out_of_memory(void);
+static void initialize_seginfo(seginfo *si, ISPC s, IGEN g);
+static seginfo *allocate_segments(uptr nreq);
+static void expand_segment_table(uptr base, uptr end, seginfo *si);
+static void contract_segment_table(uptr base, uptr end);
+static void add_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list);
+static seginfo *sort_seginfo(seginfo *si, uptr n);
+static seginfo *merge_seginfo(seginfo *si1, seginfo *si2);
+
+void S_segment_init(void) {
+  IGEN g; ISPC s; int i;
+
+  if (!S_boot_time) return;
+
+  S_chunks_full = NULL;
+  for (i = PARTIAL_CHUNK_POOLS; i >= 0; i -= 1) S_chunks[i] = NULL;
+  for (g = 0; g <= static_generation; g++) {
+    for (s = 0; s <= max_real_space; s++) {
+      S_G.occupied_segments[g][s] = NULL;
+    }
+  }
+  S_G.number_of_nonstatic_segments = 0;
+  S_G.number_of_empty_segments = 0;
+}
+
+static uptr membytes = 0;
+static uptr maxmembytes = 0;
+
+static void out_of_memory(void) {
+  (void) fprintf(stderr,"out of memory\n");
+  S_abnormal_exit();
+}
+
+#if defined(USE_MALLOC)
+void *S_getmem(iptr bytes, IBOOL zerofill) {
+  void *addr;
+
+  if ((addr = malloc(bytes)) == (void *)0) out_of_memory();
+
+  debug(printf("getmem(%p) -> %p\n", bytes, addr))
+  if ((membytes += bytes) > maxmembytes) maxmembytes = membytes;
+  if (zerofill) memset(addr, 0, bytes);
+  return addr;
+}
+
+void S_freemem(void *addr, iptr bytes) {
+  debug(printf("freemem(%p, %p)\n", addr, bytes))
+  free(addr);
+  membytes -= bytes;
+}
+#endif
+
+#if defined(USE_VIRTUAL_ALLOC)
+#include <winbase.h>
+void *S_getmem(iptr bytes, IBOOL zerofill) {
+  void *addr;
+
+  if ((uptr)bytes < S_pagesize) {
+    if ((addr = malloc(bytes)) == (void *)0) out_of_memory();
+    debug(printf("getmem malloc(%p) -> %p\n", bytes, addr))
+    if ((membytes += bytes) > maxmembytes) maxmembytes = membytes;
+    if (zerofill) memset(addr, 0, bytes);
+  } else {
+    uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n);
+    if ((addr = VirtualAlloc((void *)0, (SIZE_T)p_bytes, MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == (void *)0) out_of_memory();
+    if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes;
+    debug(printf("getmem VirtualAlloc(%p => %p) -> %p\n", bytes, p_bytes, addr))
+  }
+
+  return addr;
+}
+
+void S_freemem(void *addr, iptr bytes) {
+  if ((uptr)bytes < S_pagesize) {
+    debug(printf("freemem free(%p, %p)\n", addr, bytes))
+    membytes -= bytes;
+    free(addr);
+  } else {
+    uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n);
+    debug(printf("freemem VirtualFree(%p, %p => %p)\n", addr, bytes, p_bytes))
+    membytes -= p_bytes;
+    VirtualFree(addr, 0, MEM_RELEASE);
+  }
+}
+#endif
+
+#if defined(USE_MMAP)
+#include <sys/mman.h>
+#ifndef MAP_ANONYMOUS
+#define MAP_ANONYMOUS MAP_ANON
+#endif
+void *S_getmem(iptr bytes, IBOOL zerofill) {
+  void *addr;
+
+  if ((uptr)bytes < S_pagesize) {
+    if ((addr = malloc(bytes)) == (void *)0) out_of_memory();
+    debug(printf("getmem malloc(%p) -> %p\n", bytes, addr))
+    if ((membytes += bytes) > maxmembytes) maxmembytes = membytes;
+    if (zerofill) memset(addr, 0, bytes);
+  } else {
+    uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n);
+#ifdef MAP_32BIT
+    /* try for first 2GB of the memory space first of x86_64 so that we have a
+       better chance of having short jump instructions */
+    if ((addr = mmap(NULL, p_bytes, PROT_EXEC|PROT_WRITE|PROT_READ, MAP_PRIVATE|MAP_ANONYMOUS|MAP_32BIT, -1, 0)) == (void *)-1) {
+#endif
+      if ((addr = mmap(NULL, p_bytes, PROT_EXEC|PROT_WRITE|PROT_READ, MAP_PRIVATE|MAP_ANONYMOUS, -1, 0)) == (void *)-1) {
+        out_of_memory();
+        debug(printf("getmem mmap(%p) -> %p\n", bytes, addr))
+      }
+#ifdef MAP_32BIT
+    }
+#endif
+    if ((membytes += p_bytes) > maxmembytes) maxmembytes = membytes;
+    debug(printf("getmem mmap(%p => %p) -> %p\n", bytes, p_bytes, addr))
+  }
+
+  return addr;
+}
+
+void S_freemem(void *addr, iptr bytes) {
+  if ((uptr)bytes < S_pagesize) {
+    debug(printf("freemem free(%p, %p)\n", addr, bytes))
+    free(addr);
+    membytes -= bytes;
+  } else {
+    uptr n = S_pagesize - 1; iptr p_bytes = (iptr)(((uptr)bytes + n) & ~n);
+    debug(printf("freemem munmap(%p, %p => %p)\n", addr, bytes, p_bytes))
+    munmap(addr, p_bytes);
+    membytes -= p_bytes;
+  }
+}
+#endif
+
+void S_move_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list) {
+  if ((*chunk->prev = chunk->next) != NULL) chunk->next->prev = chunk->prev;
+  add_to_chunk_list(chunk, pchunk_list);
+}
+
+static void add_to_chunk_list(chunkinfo *chunk, chunkinfo **pchunk_list) {
+  if ((chunk->next = *pchunk_list) != NULL) (*pchunk_list)->prev = &chunk->next;
+  chunk->prev = pchunk_list;
+  *pchunk_list = chunk;
+}
+
+#define SEGLT(x, y) ((x)->number < (y)->number)
+#define SEGCDR(x) ((x)->next)
+mkmergesort(sort_seginfo, merge_seginfo, seginfo *, NULL, SEGLT, SEGCDR)
+
+static void sort_chunk_unused_segments(chunkinfo *chunk) {
+  seginfo *si, *nextsi, *sorted, *unsorted; uptr n;
+
+  /* bail out early if we find the unused segments list is already sorted */
+  if ((unsorted = chunk->unused_segs)->sorted) return;
+
+  /* find the sorted tail so we can just sort in the unsorted ones */
+  si = unsorted;
+  n = 1;
+  for (;;) {
+    si->sorted = 1;
+    if ((nextsi = si->next) == NULL || nextsi->sorted) {
+      sorted = nextsi;
+      si->next = NULL;
+      break;
+    }
+    si = nextsi;
+    n += 1;
+  }
+
+  sorted = merge_seginfo(sort_seginfo(unsorted, n), sorted);
+
+  chunk->unused_segs = sorted;
+}
+
+static INT find_index(iptr n) {
+  INT index = (INT)((n >> 2) + 1);
+
+  return (index < PARTIAL_CHUNK_POOLS-1) ? index : PARTIAL_CHUNK_POOLS-1;
+}
+
+static void initialize_seginfo(seginfo *si, ISPC s, IGEN g) {
+  INT d;
+
+  si->space = s;
+  si->generation = g;
+  si->sorted = 0;
+  si->min_dirty_byte = 0xff;
+  si->trigger_ephemerons = NULL;
+  for (d = 0; d < cards_per_segment; d += sizeof(ptr)) {
+    iptr *dp = (iptr *)(si->dirty_bytes + d);
+    /* fill sizeof(iptr) bytes at a time with 0xff */
+    *dp = -1;
+  }
+}
+
+iptr S_find_segments(ISPC s, IGEN g, iptr n) {
+  chunkinfo *chunk, *nextchunk;
+  seginfo *si, *nextsi, **prevsi;
+  iptr nunused_segs, j;
+  INT i, loser_index;
+
+  if (g != static_generation) S_G.number_of_nonstatic_segments += n;
+
+  debug(printf("attempting to find %d segments for space %d, generation %d\n", n, s, g))
+
+  if (n == 1) {
+    for (i = 0; i <= PARTIAL_CHUNK_POOLS; i++) {
+      chunk = S_chunks[i];
+      if (chunk != NULL) {
+        si = chunk->unused_segs;
+        chunk->unused_segs = si->next;
+
+        if (chunk->unused_segs == NULL) {
+          S_move_to_chunk_list(chunk, &S_chunks_full);
+        } else if (i == PARTIAL_CHUNK_POOLS) {
+          S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]);
+        }
+
+        chunk->nused_segs += 1;
+        initialize_seginfo(si, s, g);
+        si->next = S_G.occupied_segments[g][s];
+        S_G.occupied_segments[g][s] = si;
+        S_G.number_of_empty_segments -= 1;
+        return si->number;
+      }
+    }
+  } else {
+    loser_index = (n == 2) ? 0 : find_index(n-1);
+    for (i = find_index(n); i <= PARTIAL_CHUNK_POOLS; i += 1) {
+      chunk = S_chunks[i];
+      while (chunk != NULL) {
+        if (n < (nunused_segs = (chunk->segs - chunk->nused_segs))) {
+          sort_chunk_unused_segments(chunk);
+          si = chunk->unused_segs;
+          prevsi = &chunk->unused_segs;
+          while (nunused_segs >= n) {
+            nextsi = si;
+            j = n - 1;
+            for (;;) {
+              nunused_segs -= 1;
+              if (nextsi->number + 1 != nextsi->next->number) {
+                si = nextsi->next;
+                prevsi = &nextsi->next;
+                break;
+              }
+              nextsi = nextsi->next;
+              if (--j == 0) {
+                *prevsi = nextsi->next;
+                if (chunk->unused_segs == NULL) {
+                  S_move_to_chunk_list(chunk, &S_chunks_full);
+                } else if (i == PARTIAL_CHUNK_POOLS) {
+                  S_move_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]);
+                }
+                chunk->nused_segs += n;
+                nextsi->next = S_G.occupied_segments[g][s];
+                S_G.occupied_segments[g][s] = si;
+                for (j = n, nextsi = si; j > 0; j -= 1, nextsi = nextsi->next) {
+                  initialize_seginfo(nextsi, s, g);
+                }
+                S_G.number_of_empty_segments -= n;
+                return si->number;
+              }
+            }
+          }
+        }
+        nextchunk = chunk->next;
+        if (i != loser_index && i != PARTIAL_CHUNK_POOLS) {
+          S_move_to_chunk_list(chunk, &S_chunks[loser_index]);
+        }
+        chunk = nextchunk;
+      }
+    }
+  }
+
+  /* we couldn't find space, so ask for more */
+  si = allocate_segments(n);
+  for (nextsi = si; n > 0; n -= 1, nextsi += 1) {
+    initialize_seginfo(nextsi, s, g);
+    /* add segment to appropriate list of occupied segments */
+    nextsi->next = S_G.occupied_segments[g][s];
+    S_G.occupied_segments[g][s] = nextsi;
+  }
+  return si->number;
+}
+
+/* allocate_segments(n)
+ * allocates a group of n contiguous fresh segments, returning the
+ * segment number of the first segment of the group.
+ */
+static seginfo *allocate_segments(nreq) uptr nreq; {
+  uptr nact, bytes, base; void *addr;
+  iptr i;
+  chunkinfo *chunk; seginfo *si;
+
+  nact = nreq < minimum_segment_request ? minimum_segment_request : nreq;
+
+  bytes = (nact + 1) * bytes_per_segment;
+  addr = S_getmem(bytes, 0);
+  debug(printf("allocate_segments addr = %p\n", addr))
+
+  base = addr_get_segment((uptr)addr + bytes_per_segment - 1);
+  /* if the base of the first segment is the same as the base of the chunk, and
+     the last segment isn't the last segment in memory (which could cause 'next' and 'end'
+     pointers to wrap), we've actually got nact + 1 usable segments in this chunk */
+  if (build_ptr(base, 0) == addr && base + nact != ((uptr)1 << (ptr_bits - segment_offset_bits)) - 1)
+    nact += 1;
+
+  chunk = S_getmem(sizeof(chunkinfo) + sizeof(seginfo) * nact, 0);
+  debug(printf("allocate_segments chunk = %p\n", chunk))
+  chunk->addr = addr;
+  chunk->base = base;
+  chunk->bytes = bytes;
+  chunk->segs = nact;
+  chunk->nused_segs = nreq;
+  chunk->unused_segs = NULL;
+
+  expand_segment_table(base, base + nact, &chunk->sis[0]);
+
+  /* initialize seginfos */
+  for (i = nact - 1; i >= 0; i -= 1) {
+    si = &chunk->sis[i];
+    si->chunk = chunk;
+    si->number = i + base;
+    if (i >= (iptr)nreq) {
+      si->space = space_empty;
+      si->generation = 0;
+      si->sorted = 1; /* inserting in reverse order, so emptys are always sorted */
+      si->next = chunk->unused_segs;
+      chunk->unused_segs = si;
+    }
+  }
+
+ /* account for trailing empty segments */
+  if (nact > nreq) {
+    S_G.number_of_empty_segments += nact - nreq;
+    add_to_chunk_list(chunk, &S_chunks[PARTIAL_CHUNK_POOLS-1]);
+  } else {
+    add_to_chunk_list(chunk, &S_chunks_full);
+  }
+
+  return &chunk->sis[0];
+}
+
+void S_free_chunk(chunkinfo *chunk) {
+  chunkinfo *nextchunk = chunk->next;
+  contract_segment_table(chunk->base, chunk->base + chunk->segs);
+  S_G.number_of_empty_segments -= chunk->segs;
+  *chunk->prev = nextchunk;
+  if (nextchunk != NULL) nextchunk->prev = chunk->prev;
+  S_freemem(chunk->addr, chunk->bytes);
+  S_freemem(chunk, sizeof(chunkinfo) + sizeof(seginfo) * chunk->segs);
+}
+
+/* retain approximately heap-reserve-ratio segments for every
+ * nonempty nonstatic segment. */
+void S_free_chunks(void) {
+  iptr ntofree;
+  chunkinfo *chunk, *nextchunk;
+
+  ntofree = S_G.number_of_empty_segments -
+    (iptr)(Sflonum_value(SYMVAL(S_G.heap_reserve_ratio_id)) * S_G.number_of_nonstatic_segments);
+
+  for (chunk = S_chunks[PARTIAL_CHUNK_POOLS]; ntofree > 0 && chunk != NULL; chunk = nextchunk) {
+    nextchunk = chunk->next;
+    ntofree -= chunk->segs;
+    S_free_chunk(chunk);
+  }
+}
+
+uptr S_curmembytes(void) {
+  return membytes;
+}
+
+uptr S_maxmembytes(void) {
+  return maxmembytes;
+}
+
+void S_resetmaxmembytes(void) {
+  maxmembytes = membytes;
+}
+
+static void expand_segment_table(uptr base, uptr end, seginfo *si) {
+#ifdef segment_t2_bits
+#ifdef segment_t3_bits
+  t2table *t2i;
+#endif
+  t1table **t2, *t1i; uptr n;
+#endif
+  seginfo **t1, **t1end;
+
+#ifdef segment_t2_bits
+  while (base != end) {
+#ifdef segment_t3_bits
+    if ((t2i = S_segment_info[SEGMENT_T3_IDX(base)]) == NULL) {
+      S_segment_info[SEGMENT_T3_IDX(base)] = t2i = (t2table *)S_getmem(sizeof(t2table), 1);
+    }
+    t2 = t2i->t2;
+#else
+    t2 = S_segment_info;
+#endif
+    if ((t1i = t2[SEGMENT_T2_IDX(base)]) == NULL) {
+      t2[SEGMENT_T2_IDX(base)] = t1i = (t1table *)S_getmem(sizeof(t1table), 1);
+#ifdef segment_t3_bits
+      t2i->refcount += 1;
+#endif
+    }
+    t1 = t1i->t1 + SEGMENT_T1_IDX(base);
+    t1end = t1 + end - base < t1i->t1 + SEGMENT_T1_SIZE ? t1 + end - base : t1i->t1 + SEGMENT_T1_SIZE;
+    n = t1end - t1;
+    t1i->refcount += n;
+
+    while (t1 < t1end) *t1++ = si++;
+    base += n;
+  }
+#else
+  t1 = S_segment_info + SEGMENT_T1_IDX(base);
+  t1end = t1 + end - base;
+  while (t1 < t1end) *t1++ = si++;
+#endif
+}
+
+static void contract_segment_table(uptr base, uptr end) {
+#ifdef segment_t2_bits
+#ifdef segment_t3_bits
+  t2table *t2i;
+#endif
+  t1table **t2, *t1i; uptr n;
+#endif
+  seginfo **t1, **t1end;
+
+#ifdef segment_t2_bits
+  while (base != end) {
+#ifdef segment_t3_bits
+    t2i = S_segment_info[SEGMENT_T3_IDX(base)];
+    t2 = t2i->t2;
+#else
+    t2 = S_segment_info;
+#endif
+    t1i = t2[SEGMENT_T2_IDX(base)];
+    t1 = t1i->t1 + SEGMENT_T1_IDX(base);
+    t1end = t1 + end - base < t1i->t1 + SEGMENT_T1_SIZE ? t1 + end - base : t1i->t1 + SEGMENT_T1_SIZE;
+    n = t1end - t1;
+    if ((t1i->refcount -= n) == 0) {
+      S_freemem((void *)t1i, sizeof(t1table));
+#ifdef segment_t3_bits
+      if ((t2i->refcount -= 1) == 0) {
+        S_freemem((void *)t2i, sizeof(t2table));
+        S_segment_info[SEGMENT_T3_IDX(base)] = NULL;
+      } else {
+        S_segment_info[SEGMENT_T3_IDX(base)]->t2[SEGMENT_T2_IDX(base)] = NULL;
+      }
+#else
+      S_segment_info[SEGMENT_T2_IDX(base)] = NULL;
+#endif
+    } else {
+      while (t1 < t1end) *t1++ = NULL;
+    }
+    base += n;
+  }
+#else
+  t1 = S_segment_info + SEGMENT_T1_IDX(base);
+  t1end = t1 + end - base;
+  while (t1 < t1end) *t1++ = NULL;
+#endif
+}

ta6ob/c/segment.h

@@ -0,0 +1,83 @@
+/* segment.h
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#ifdef WIN32
+# ifndef __MINGW32__
+#  undef FORCEINLINE
+#  define FORCEINLINE static __forceinline
+# endif
+#else
+#define FORCEINLINE static inline
+#endif
+
+/* segment_info */
+
+#define SEGMENT_T1_SIZE (1<<segment_t1_bits)
+#define SEGMENT_T1_IDX(i) ((i)&(SEGMENT_T1_SIZE-1))
+
+#ifdef segment_t3_bits
+
+#define SEGMENT_T2_SIZE (1<<segment_t2_bits)
+#define SEGMENT_T2_IDX(i) (((i)>>segment_t1_bits)&(SEGMENT_T2_SIZE-1))
+#define SEGMENT_T3_SIZE (1<<segment_t3_bits)
+#define SEGMENT_T3_IDX(i) ((i)>>(segment_t2_bits+segment_t1_bits))
+
+FORCEINLINE seginfo *SegInfo(uptr i) {
+  return S_segment_info[SEGMENT_T3_IDX(i)]->t2[SEGMENT_T2_IDX(i)]->t1[SEGMENT_T1_IDX(i)];
+}
+
+FORCEINLINE seginfo *MaybeSegInfo(uptr i) {
+  t2table *t2i; t1table *t1i;
+  if ((t2i = S_segment_info[SEGMENT_T3_IDX(i)]) == NULL) return NULL;
+  if ((t1i = t2i->t2[SEGMENT_T2_IDX(i)]) == NULL) return NULL;
+  return t1i->t1[SEGMENT_T1_IDX(i)];
+}
+
+#else /* segment_t3_bits */
+#ifdef segment_t2_bits
+
+#define SEGMENT_T2_SIZE (1<<segment_t2_bits)
+#define SEGMENT_T2_IDX(i) ((i)>>segment_t1_bits)
+#define SEGMENT_T3_SIZE 0
+
+FORCEINLINE seginfo *SegInfo(uptr i) {
+  return S_segment_info[SEGMENT_T2_IDX(i)]->t1[SEGMENT_T1_IDX(i)];
+}
+
+FORCEINLINE seginfo *MaybeSegInfo(uptr i) {
+  t1table *t1i;
+  if ((t1i = S_segment_info[SEGMENT_T2_IDX(i)]) == NULL) return NULL;
+  return t1i->t1[SEGMENT_T1_IDX(i)];
+}
+
+#else /* segment_t2_bits */
+
+#define SEGMENT_T2_SIZE 0
+#define SEGMENT_T3_SIZE 0
+
+FORCEINLINE seginfo *SegInfo(uptr i) {
+  return S_segment_info[SEGMENT_T1_IDX(i)];
+}
+
+FORCEINLINE seginfo *MaybeSegInfo(uptr i) {
+  return S_segment_info[SEGMENT_T1_IDX(i)];
+}
+
+#endif /* segment_t2_bits */
+#endif /* segment_t3_bits */
+
+#define SegmentSpace(i) (SegInfo(i)->space)
+#define SegmentGeneration(i) (SegInfo(i)->generation)

ta6ob/c/sort.h

@@ -0,0 +1,40 @@
+/* sort.h
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#define mkmergesort(sort, merge, type, nil, lt, cdr)\
+type sort(type ls, uptr len) {\
+  if (len == 1) {\
+    cdr(ls) = nil;\
+    return ls;\
+  } else {\
+    uptr head_len, i; type tail;\
+    head_len = len >> 1;\
+    for (tail = ls, i = head_len; i != 0; i -= 1) tail = cdr(tail);\
+    return merge(sort(ls, head_len), sort(tail, len - head_len));\
+  }\
+}\
+type merge(type ls1, type ls2) {\
+  type p; type *pp = &p;\
+  for (;;) {\
+    if (ls1 == nil) { *pp = ls2; break; }\
+    if (ls2 == nil) { *pp = ls1; break; }\
+    if (lt(ls2, ls1))\
+      { *pp = ls2; pp = &cdr(ls2); ls2 = cdr(ls2); }\
+    else\
+      { *pp = ls1; pp = &cdr(ls1); ls1 = cdr(ls1); }\
+  }\
+  return p;\
+}

ta6ob/c/statics.c

@@ -0,0 +1,22 @@
+/* statics.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#define EXTERN
+#include "system.h"
+
+/* The C linker may require a reference to a function to pull in all
+   the common declarations. */
+void scheme_statics(void) { }

ta6ob/c/stats.c

@@ -0,0 +1,528 @@
+/* stats.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#if defined(SOLARIS)
+/* make gmtime_r and localtime_r visible */
+#ifndef _REENTRANT
+#define _REENTRANT
+#endif
+/* make two-argument ctime_r and two-argument asctime_r visible */
+#define _POSIX_PTHREAD_SEMANTICS
+#endif /* defined(SOLARIS) */
+
+#include "system.h"
+
+#ifdef WIN32
+#include <sys/types.h>
+#include <sys/timeb.h>
+#else /* WIN32 */
+#include <sys/types.h>
+#include <sys/time.h>
+#include <sys/resource.h>
+#endif
+
+static struct timespec starting_mono_tp;
+
+static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff);
+
+/********  unique-id  ********/
+
+#if (time_t_bits == 32)
+#define S_integer_time_t(x) Sinteger32((iptr)(x))
+#elif (time_t_bits == 64)
+#define S_integer_time_t(x) Sinteger64(x)
+#endif
+
+#ifdef WIN32
+
+#include <rpc.h>
+
+ptr S_unique_id(void) {
+  union {UUID uuid; U32 foo[4];} u;
+  u.foo[0] = 0;
+  u.foo[1] = 0;
+  u.foo[2] = 0;
+  u.foo[3] = 0;
+  UuidCreate(&u.uuid);
+  return S_add(S_ash(Sunsigned32(u.foo[0]), Sinteger(8*3*sizeof(U32))),
+           S_add(S_ash(Sunsigned32(u.foo[1]), Sinteger(8*2*sizeof(U32))),
+             S_add(S_ash(Sunsigned32(u.foo[2]), Sinteger(8*sizeof(U32))),
+              Sunsigned32(u.foo[3]))));
+}
+
+#elif defined(USE_OSSP_UUID) /* WIN32 */
+
+#include <ossp/uuid.h>
+
+ptr S_unique_id(void) {
+  uuid_t *uuid;
+  U32 bin[4];
+  void *bin_ptr = &bin;
+  size_t bin_len = sizeof(bin);
+
+  uuid_create(&uuid);
+  uuid_make(uuid, UUID_MAKE_V4);
+  uuid_export(uuid, UUID_FMT_BIN, &bin_ptr, &bin_len);
+  uuid_destroy(uuid);
+
+  return S_add(S_ash(Sunsigned32(bin[0]), Sinteger(8*3*sizeof(U32))),
+           S_add(S_ash(Sunsigned32(bin[1]), Sinteger(8*2*sizeof(U32))),
+             S_add(S_ash(Sunsigned32(bin[2]), Sinteger(8*sizeof(U32))),
+              Sunsigned32(bin[3]))));
+}
+
+#elif defined(USE_NETBSD_UUID) /* USE_OSSP_UUID */
+
+#include <uuid.h>
+
+ptr S_unique_id(void) {
+  uuid_t uuid;
+  uint32_t status;
+  unsigned char bin[16];
+  ptr n;
+  unsigned int i;
+
+  uuid_create(&uuid, &status);
+  uuid_enc_le(bin, &uuid);
+
+  n = Sinteger(0);
+  for (i = 0; i < sizeof(bin); i++) {
+    n = S_add(n, S_ash(Sinteger(bin[i]), Sinteger(8*i)));
+  }
+
+  return n;
+}
+
+#else /* USE_NETBSD_UUID */
+
+#include <uuid/uuid.h>
+
+ptr S_unique_id(void) {
+  union {uuid_t uuid; U32 foo[4];} u;
+  u.foo[0] = 0;
+  u.foo[1] = 0;
+  u.foo[2] = 0;
+  u.foo[3] = 0;
+  uuid_generate(u.uuid);
+  return S_add(S_ash(Sunsigned32(u.foo[0]), Sinteger(8*3*sizeof(U32))),
+           S_add(S_ash(Sunsigned32(u.foo[1]), Sinteger(8*2*sizeof(U32))),
+             S_add(S_ash(Sunsigned32(u.foo[2]), Sinteger(8*sizeof(U32))),
+              Sunsigned32(u.foo[3]))));
+}
+
+#endif /* WIN32 */
+
+
+/********  time and date support  ********/
+
+#ifdef WIN32
+
+static __int64 hires_cps = 0;
+
+typedef void (WINAPI *GetSystemTimeAsFileTime_t)(LPFILETIME lpSystemTimeAsFileTime);
+
+static GetSystemTimeAsFileTime_t s_GetSystemTimeAsFileTime = GetSystemTimeAsFileTime;
+
+void S_gettime(INT typeno, struct timespec *tp) {
+  switch (typeno) {
+    case time_process: {
+      FILETIME ftKernel, ftUser, ftDummy;
+
+      if (GetProcessTimes(GetCurrentProcess(), &ftDummy, &ftDummy,
+                          &ftKernel, &ftUser)) {
+        __int64 kernel, user, total;
+        kernel = ftKernel.dwHighDateTime;
+        kernel <<= 32;
+        kernel |= ftKernel.dwLowDateTime;
+        user = ftUser.dwHighDateTime;
+        user <<= 32;
+        user |= ftUser.dwLowDateTime;
+        total = user + kernel;
+        tp->tv_sec = (time_t)(total / 10000000);
+        tp->tv_nsec = (long)((total % 10000000) * 100);
+        break;
+      } else {
+        clock_t n = clock();;
+      /* if GetProcessTimes fails, we're probably running Windows 95 */
+        tp->tv_sec = (time_t)(n / CLOCKS_PER_SEC);
+        tp->tv_nsec = (long)((n % CLOCKS_PER_SEC) * (1000000000 / CLOCKS_PER_SEC));
+        break;
+      }
+    }
+
+    case time_thread: {
+      FILETIME ftKernel, ftUser, ftDummy;
+
+      if (GetThreadTimes(GetCurrentThread(), &ftDummy, &ftDummy,
+                          &ftKernel, &ftUser)) {
+        __int64 kernel, user, total;
+        kernel = ftKernel.dwHighDateTime;
+        kernel <<= 32;
+        kernel |= ftKernel.dwLowDateTime;
+        user = ftUser.dwHighDateTime;
+        user <<= 32;
+        user |= ftUser.dwLowDateTime;
+        total = user + kernel;
+        tp->tv_sec = (time_t)(total / 10000000);
+        tp->tv_nsec = (long)((total % 10000000) * 100);
+        break;
+      } else {
+        clock_t n = clock();;
+      /* if GetThreadTimes fails, we're probably running Windows 95 */
+        tp->tv_sec = (time_t)(n / CLOCKS_PER_SEC);
+        tp->tv_nsec = (long)((n % CLOCKS_PER_SEC) * (1000000000 / CLOCKS_PER_SEC));
+        break;
+      }
+    }
+
+    case time_duration:
+    case time_monotonic: {
+      LARGE_INTEGER count;
+
+      if (hires_cps == 0 && QueryPerformanceFrequency(&count))
+        hires_cps = count.QuadPart;
+
+      if (hires_cps && QueryPerformanceCounter(&count)) {
+        tp->tv_sec = (time_t)(count.QuadPart / hires_cps);
+        tp->tv_nsec = (long)((count.QuadPart % hires_cps) * (1000000000 / hires_cps));
+        break;
+      } else {
+        DWORD count = GetTickCount();
+        tp->tv_sec = (time_t)(count / 1000);
+        tp->tv_nsec = (long)((count % 1000) * 1000000);
+        break;
+      }
+    }
+
+    case time_utc: {
+      FILETIME ft; __int64 total;
+
+      s_GetSystemTimeAsFileTime(&ft);
+      total = ft.dwHighDateTime;
+      total <<= 32;
+      total |= ft.dwLowDateTime;
+     /* measurement interval is 100 nanoseconds = 1/10 microseconds */
+     /* adjust by number of seconds between Windows (1601) and Unix (1970) epochs */
+      tp->tv_sec = (time_t)(total / 10000000 - 11644473600L);
+      tp->tv_nsec = (long)((total % 10000000) * 100);
+      break;
+    }
+
+    default:
+      S_error1("S_gettime", "unexpected typeno ~s", Sinteger(typeno));
+      break;
+  }
+}
+
+static struct tm *gmtime_r(const time_t *timep, struct tm *result) {
+  return gmtime_s(result, timep) == 0 ? result : NULL;
+}
+
+static struct tm *localtime_r(const time_t *timep, struct tm *result) {
+  return localtime_s(result, timep) == 0 ? result : NULL;
+}
+
+static char *ctime_r(const time_t *timep, char *buf) {
+  return ctime_s(buf, 26, timep) == 0 ? buf : NULL;
+}
+
+static char *asctime_r(const struct tm *tm, char *buf) {
+  return asctime_s(buf, 26, tm) == 0 ? buf : NULL;
+}
+
+#else /* WIN32 */
+
+void S_gettime(INT typeno, struct timespec *tp) {
+  switch (typeno) {
+    case time_thread:
+#ifdef CLOCK_THREAD_CPUTIME_ID
+      if (clock_gettime(CLOCK_THREAD_CPUTIME_ID, tp) == 0) return;
+#endif
+     /* fall through */
+     /* to utc case in case no thread timer */
+    case time_process:
+#ifdef CLOCK_PROCESS_CPUTIME_ID
+      if (clock_gettime(CLOCK_PROCESS_CPUTIME_ID, tp) == 0) return;
+#endif
+     /* fall back on getrusage if clock_gettime fails */
+      {
+        struct rusage rbuf;
+
+        if (getrusage(RUSAGE_SELF,&rbuf) != 0)
+          S_error1("S_gettime", "failed: ~s", S_strerror(errno));
+        tp->tv_sec = rbuf.ru_utime.tv_sec + rbuf.ru_stime.tv_sec;
+        tp->tv_nsec = (rbuf.ru_utime.tv_usec + rbuf.ru_stime.tv_usec) * 1000;
+        if (tp->tv_nsec >= 1000000000) {
+          tp->tv_sec += 1;
+          tp->tv_nsec -= 1000000000;
+        }
+        return;
+      }
+    case time_duration:
+    case time_monotonic:
+#ifdef CLOCK_MONOTONIC_HR
+      if (clock_gettime(CLOCK_MONOTONIC_HR, tp) == 0) return;
+#endif
+#ifdef CLOCK_MONOTONIC
+      if (clock_gettime(CLOCK_MONOTONIC, tp) == 0) return;
+#endif
+#ifdef CLOCK_HIGHRES
+      if (clock_gettime(CLOCK_HIGHRES, tp) == 0) return;
+#endif
+     /* fall through */
+     /* to utc case in case no monotonic timer */
+    case time_utc:
+#ifdef CLOCK_REALTIME_HR
+      if (clock_gettime(CLOCK_REALTIME_HR, tp) == 0) return;
+#endif
+#ifdef CLOCK_REALTIME
+      if (clock_gettime(CLOCK_REALTIME, tp) == 0) return;
+#endif
+     /* fall back on gettimeofday if clock_gettime fails */
+      {
+        struct timeval tvtp;
+
+        if (gettimeofday(&tvtp,NULL) != 0)
+          S_error1("S_gettime", "failed: ~s", S_strerror(errno));
+        tp->tv_sec = (time_t)tvtp.tv_sec;
+        tp->tv_nsec = (long)(tvtp.tv_usec * 1000);
+        return;
+      }
+    default:
+      S_error1("S_gettime", "unexpected typeno ~s", Sinteger(typeno));
+      break;
+  }
+}
+
+#endif /* WIN32 */
+
+ptr S_clock_gettime(I32 typeno) {
+  struct timespec tp;
+  time_t sec; I32 nsec;
+
+  S_gettime(typeno, &tp);
+
+  sec = tp.tv_sec;
+  nsec = tp.tv_nsec;
+
+  if (typeno == time_monotonic || typeno == time_duration) {
+    sec -= starting_mono_tp.tv_sec;
+    nsec -= starting_mono_tp.tv_nsec;
+    if (nsec < 0) {
+      sec -= 1;
+      nsec += 1000000000;
+    }
+  }
+
+  return Scons(S_integer_time_t(sec), Sinteger(nsec));
+}
+
+ptr S_gmtime(ptr tzoff, ptr tspair) {
+  time_t tx;
+  struct tm tmx;
+  ptr dtvec = S_vector(dtvec_size);
+
+  if (tspair == Sfalse) {
+    struct timespec tp;
+
+    S_gettime(time_utc, &tp);
+    tx = tp.tv_sec;
+    INITVECTIT(dtvec, dtvec_nsec) = Sinteger(tp.tv_nsec);
+  } else {
+    tx = Sinteger_value(Scar(tspair));
+    INITVECTIT(dtvec, dtvec_nsec) = Scdr(tspair);
+  }
+
+  if (tzoff == Sfalse) {
+    if (localtime_r(&tx, &tmx) == NULL) return Sfalse;
+    tmx.tm_isdst = -1; /* have mktime determine the DST status */
+    if (mktime(&tmx) == (time_t)-1) return Sfalse;
+    (void) adjust_time_zone(dtvec, &tmx, Sfalse);
+  } else {
+    tx += Sinteger_value(tzoff);
+    if (gmtime_r(&tx, &tmx) == NULL) return Sfalse;
+    INITVECTIT(dtvec, dtvec_tzoff) = tzoff;
+    INITVECTIT(dtvec, dtvec_isdst) = Sfalse;
+    INITVECTIT(dtvec, dtvec_tzname) = Sfalse;
+  }
+
+  INITVECTIT(dtvec, dtvec_sec) = Sinteger(tmx.tm_sec);
+  INITVECTIT(dtvec, dtvec_min) = Sinteger(tmx.tm_min);
+  INITVECTIT(dtvec, dtvec_hour) = Sinteger(tmx.tm_hour);
+  INITVECTIT(dtvec, dtvec_mday) = Sinteger(tmx.tm_mday);
+  INITVECTIT(dtvec, dtvec_mon) = Sinteger(tmx.tm_mon + 1);
+  INITVECTIT(dtvec, dtvec_year) = Sinteger(tmx.tm_year);
+  INITVECTIT(dtvec, dtvec_wday) = Sinteger(tmx.tm_wday);
+  INITVECTIT(dtvec, dtvec_yday) = Sinteger(tmx.tm_yday);
+
+  return dtvec;
+}
+
+ptr S_asctime(ptr dtvec) {
+  char buf[26];
+
+  if (dtvec == Sfalse) {
+    time_t tx = time(NULL);
+    if (ctime_r(&tx, buf) == NULL) return Sfalse;
+  } else {
+    struct tm tmx;
+    tmx.tm_sec = (int)Sinteger_value(Svector_ref(dtvec, dtvec_sec));
+    tmx.tm_min = (int)Sinteger_value(Svector_ref(dtvec, dtvec_min));
+    tmx.tm_hour = (int)Sinteger_value(Svector_ref(dtvec, dtvec_hour));
+    tmx.tm_mday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mday));
+    tmx.tm_mon = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mon)) - 1;
+    tmx.tm_year = (int)Sinteger_value(Svector_ref(dtvec, dtvec_year));
+    tmx.tm_wday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_wday));
+    tmx.tm_yday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_yday));
+    tmx.tm_isdst = (int)Sboolean_value(Svector_ref(dtvec, dtvec_isdst));
+    if (asctime_r(&tmx, buf) == NULL) return Sfalse;
+  }
+
+  return S_string(buf, 24) /* all but trailing newline */;
+}
+
+ptr S_mktime(ptr dtvec) {
+  time_t tx;
+  struct tm tmx;
+  long orig_tzoff, tzoff;
+  ptr given_tzoff;
+
+  tmx.tm_sec = (int)Sinteger_value(Svector_ref(dtvec, dtvec_sec));
+  tmx.tm_min = (int)Sinteger_value(Svector_ref(dtvec, dtvec_min));
+  tmx.tm_hour = (int)Sinteger_value(Svector_ref(dtvec, dtvec_hour));
+  tmx.tm_mday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mday));
+  tmx.tm_mon = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mon)) - 1;
+  tmx.tm_year = (int)Sinteger_value(Svector_ref(dtvec, dtvec_year));
+
+  given_tzoff = INITVECTIT(dtvec, dtvec_tzoff);
+  if (given_tzoff == Sfalse)
+    orig_tzoff = 0;
+  else
+    orig_tzoff = (long)UNFIX(given_tzoff);
+  
+  tmx.tm_isdst = -1; /* have mktime determine the DST status */
+  if ((tx = mktime(&tmx)) == (time_t)-1) return Sfalse;
+
+ /* mktime may have normalized some values, set wday and yday */
+  INITVECTIT(dtvec, dtvec_sec) = Sinteger(tmx.tm_sec);
+  INITVECTIT(dtvec, dtvec_min) = Sinteger(tmx.tm_min);
+  INITVECTIT(dtvec, dtvec_hour) = Sinteger(tmx.tm_hour);
+  INITVECTIT(dtvec, dtvec_mday) = Sinteger(tmx.tm_mday);
+  INITVECTIT(dtvec, dtvec_mon) = Sinteger(tmx.tm_mon + 1);
+  INITVECTIT(dtvec, dtvec_year) = Sinteger(tmx.tm_year);
+  INITVECTIT(dtvec, dtvec_wday) = Sinteger(tmx.tm_wday);
+  INITVECTIT(dtvec, dtvec_yday) = Sinteger(tmx.tm_yday);
+
+  tzoff = adjust_time_zone(dtvec, &tmx, given_tzoff);
+
+  if (tzoff != orig_tzoff) tx = tx - orig_tzoff + tzoff;
+
+  return Scons(S_integer_time_t(tx), Svector_ref(dtvec, dtvec_nsec));
+}
+
+static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff) {
+  ptr tz_name = Sfalse;
+  long use_tzoff, tzoff;
+
+#ifdef WIN32
+  {
+    TIME_ZONE_INFORMATION tz;
+    wchar_t *w_tzname;
+
+    /* The ...ForYear() function is available on Windows Vista and later: */
+    GetTimeZoneInformationForYear(tmxp->tm_year, NULL, &tz);
+    
+    if (tmxp->tm_isdst) {
+      tzoff = (tz.Bias + tz.DaylightBias) * -60;
+      w_tzname = tz.DaylightName;
+    } else {
+      tzoff = (tz.Bias + tz.StandardBias) * -60;
+      w_tzname = tz.StandardName;
+    }
+
+    if (given_tzoff == Sfalse) {
+      char *name = Swide_to_utf8(w_tzname);
+      tz_name = Sstring_utf8(name, -1);
+      free(name);
+    }
+  }
+#else
+  tzoff = tmxp->tm_gmtoff;
+  if (given_tzoff == Sfalse) {
+# if defined(__linux__) || defined(SOLARIS)
+    /* Linux and Solaris set `tzname`: */
+    tz_name = Sstring_utf8(tzname[tmxp->tm_isdst], -1);
+# else
+    /* BSD variants add `tm_zone` in `struct tm`: */
+    tz_name = Sstring_utf8(tmxp->tm_zone, -1);
+# endif
+  }
+#endif
+
+  if (given_tzoff == Sfalse)
+    use_tzoff = tzoff;
+  else
+    use_tzoff = (long)UNFIX(given_tzoff);
+
+  INITVECTIT(dtvec, dtvec_isdst) = ((given_tzoff == Sfalse) ? Sboolean(tmxp->tm_isdst) : Sfalse);
+  INITVECTIT(dtvec, dtvec_tzoff) = FIX(use_tzoff);
+  INITVECTIT(dtvec, dtvec_tzname) = tz_name;
+
+  return tzoff;
+}
+
+/********  old real-time and cpu-time support  ********/
+
+ptr S_cputime(void) {
+  struct timespec tp;
+
+  S_gettime(time_process, &tp);
+  return S_add(S_mul(S_integer_time_t(tp.tv_sec), FIX(1000)),
+               Sinteger((tp.tv_nsec + 500000) / 1000000));
+}
+
+ptr S_realtime(void) {
+  struct timespec tp;
+  time_t sec; I32 nsec;
+
+  S_gettime(time_monotonic, &tp);
+
+  sec = tp.tv_sec - starting_mono_tp.tv_sec;
+  nsec = tp.tv_nsec - starting_mono_tp.tv_nsec;
+  if (nsec < 0) {
+    sec -= 1;
+    nsec += 1000000000;
+  }
+  return S_add(S_mul(S_integer_time_t(sec), FIX(1000)),
+               Sinteger((nsec + 500000) / 1000000));
+}
+
+/********  initialization  ********/
+
+void S_stats_init(void) {
+#ifdef WIN32
+  /* Use GetSystemTimePreciseAsFileTime when available (Windows 8 and later). */
+  HMODULE h = LoadLibraryW(L"kernel32.dll");
+  if (h != NULL) {
+    GetSystemTimeAsFileTime_t proc = (GetSystemTimeAsFileTime_t)GetProcAddress(h, "GetSystemTimePreciseAsFileTime");
+    if (proc != NULL)
+      s_GetSystemTimeAsFileTime = proc;
+    else
+      FreeLibrary(h);
+  }
+#endif
+  S_gettime(time_monotonic, &starting_mono_tp);
+}

ta6ob/c/symbol.c

@@ -0,0 +1,28 @@
+/* symbol.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+ptr S_symbol_value(ptr sym) {
+  if (SYMVAL(sym) == sunbound)
+    S_error1("","~s is not bound", sym);
+  return SYMVAL(sym);
+}
+
+void S_set_symbol_value(ptr sym, ptr val) {
+  SETSYMVAL(sym, val);
+  SETSYMCODE(sym, Sprocedurep(val) ? CLOSCODE(val) : S_G.nonprocedure_code);
+}

ta6ob/c/system.h

@@ -0,0 +1,47 @@
+/* system.h
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "scheme.h"
+#include "equates.h"
+#ifdef FEATURE_WINDOWS
+#ifdef __MINGW32__
+# undef WINVER
+# undef _WIN32_WINNT
+#endif
+#define WINVER 0x0601 // Windows 7
+#define _WIN32_WINNT WINVER
+#include <windows.h>
+#endif
+
+#include "version.h"
+#include <stdio.h>
+#include <stddef.h>
+
+#include "thread.h"
+
+#include "types.h"
+
+#include "compress-io.h"
+
+#ifndef EXTERN
+#define EXTERN extern
+#endif
+#include "globals.h"
+
+#include "externs.h"
+
+#include "segment.h"
+

ta6ob/c/thread.c

@@ -0,0 +1,470 @@
+/* thread.c
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "system.h"
+
+/* locally defined functions */
+#ifdef PTHREADS
+static s_thread_rv_t start_thread(void *tc);
+static IBOOL destroy_thread(ptr tc);
+#endif
+
+void S_thread_init(void) {
+  if (S_boot_time) {
+    S_protect(&S_G.threadno);
+    S_G.threadno = FIX(0);
+
+#ifdef PTHREADS
+   /* this is also reset in scheme.c after heap restoration */
+    s_thread_mutex_init(&S_tc_mutex.pmutex);
+    S_tc_mutex.owner = s_thread_self();
+    S_tc_mutex.count = 0;
+    s_thread_cond_init(&S_collect_cond);
+    S_tc_mutex_depth = 0;
+#endif /* PTHREADS */
+  }
+}
+
+/* this needs to be reworked.  currently, S_create_thread_object is
+   called from main to create the base thread, from fork_thread when
+   there is already an active current thread, and from S_activate_thread
+   when there is no current thread.  we have to avoid thread-local
+   allocation in at least the latter case, so we call vector_in and
+   cons_in and arrange for S_thread to use find_room rather than
+   thread_find_room.  scheme.c does part of the initialization of the
+   base thread (e.g., parameters, current input/output ports) in one
+   or more places. */
+ptr S_create_thread_object(const char *who, ptr p_tc) {
+  ptr thread, tc;
+  INT i;
+
+  tc_mutex_acquire()
+
+  if (S_threads == Snil) {
+    tc = (ptr)S_G.thread_context;
+  } else { /* clone parent */
+    ptr p_v = PARAMETERS(p_tc);
+    iptr i, n = Svector_length(p_v);
+   /* use S_vector_in to avoid thread-local allocation */
+    ptr v = S_vector_in(space_new, 0, n);
+
+    tc = (ptr)malloc(size_tc);
+    if (tc == (ptr)0)
+      S_error(who, "unable to malloc thread data structure");
+    memcpy((void *)tc, (void *)p_tc, size_tc);
+
+    for (i = 0; i < n; i += 1)
+      INITVECTIT(v, i) = Svector_ref(p_v, i);
+    
+    PARAMETERS(tc) = v;
+    CODERANGESTOFLUSH(tc) = Snil;
+  }
+
+ /* override nonclonable tc fields */
+  THREADNO(tc) = S_G.threadno;
+  S_G.threadno = S_add(S_G.threadno, FIX(1));
+
+  CCHAIN(tc) = Snil;
+
+  WINDERS(tc) = Snil;
+  STACKLINK(tc) = SYMVAL(S_G.null_continuation_id);
+  STACKCACHE(tc) = Snil;
+
+ /* S_reset_scheme_stack initializes stack, size, esp, and sfp */
+  S_reset_scheme_stack(tc, stack_slop);
+  FRAME(tc,0) = (ptr)&CODEIT(S_G.dummy_code_object,size_rp_header);
+
+ /* S_reset_allocation_pointer initializes ap and eap */
+  S_reset_allocation_pointer(tc);
+  RANDOMSEED(tc) = most_positive_fixnum < 0xffffffff ? most_positive_fixnum : 0xffffffff;
+  X(tc) = Y(tc) = U(tc) = V(tc) = W(tc) = FIX(0);
+
+  TIMERTICKS(tc) = Sfalse;
+  DISABLECOUNT(tc) = Sfixnum(0);
+  SIGNALINTERRUPTPENDING(tc) = Sfalse;
+  SIGNALINTERRUPTQUEUE(tc) = S_allocate_scheme_signal_queue();
+  KEYBOARDINTERRUPTPENDING(tc) = Sfalse;
+
+  TARGETMACHINE(tc) = S_intern((const unsigned char *)MACHINE_TYPE);
+
+ /* choosing not to clone virtual registers */
+  for (i = 0 ; i < virtual_register_count ; i += 1) {
+    VIRTREG(tc, i) = FIX(0);
+  }
+
+  DSTBV(tc) = SRCBV(tc) = Sfalse;
+
+ /* S_thread had better not do thread-local allocation */
+  thread = S_thread(tc);
+
+ /* use S_cons_in to avoid thread-local allocation */
+  S_threads = S_cons_in(space_new, 0, thread, S_threads);
+  S_nthreads += 1;
+  SETSYMVAL(S_G.active_threads_id,
+   FIX(UNFIX(SYMVAL(S_G.active_threads_id)) + 1));
+  ACTIVE(tc) = 1;
+
+ /* collect request is only thing that can be pending for new thread.
+    must do this after we're on the thread list in case the cons
+    adding us onto the thread list set collect-request-pending */
+  SOMETHINGPENDING(tc) = SYMVAL(S_G.collect_request_pending_id);
+
+  GUARDIANENTRIES(tc) = Snil;
+
+  LZ4OUTBUFFER(tc) = NULL;
+
+  tc_mutex_release()
+
+  return thread;
+}
+
+#ifdef PTHREADS
+IBOOL Sactivate_thread(void) { /* create or reactivate current thread */
+  ptr tc = get_thread_context();
+
+  if (tc == (ptr)0) { /* thread created by someone else */
+    ptr thread;
+
+   /* borrow base thread for now */
+    thread = S_create_thread_object("Sactivate_thread", S_G.thread_context);
+    s_thread_setspecific(S_tc_key, (ptr)THREADTC(thread));
+    return 1;
+  } else {
+    reactivate_thread(tc)
+    return 0;
+  }
+}
+
+int S_activate_thread(void) { /* Like Sactivate_thread(), but returns a mode to revert the effect */
+  ptr tc = get_thread_context();
+
+  if (tc == (ptr)0) {
+    Sactivate_thread();
+    return unactivate_mode_destroy;
+  } else if (!ACTIVE(tc)) {
+    reactivate_thread(tc);
+    return unactivate_mode_deactivate;
+  } else
+    return unactivate_mode_noop;
+}
+
+void S_unactivate_thread(int mode) { /* Reverts a previous S_activate_thread() effect */
+  switch (mode) {
+  case unactivate_mode_deactivate:
+    Sdeactivate_thread();
+    break;
+  case unactivate_mode_destroy:
+    Sdestroy_thread();
+    break;
+  case unactivate_mode_noop:
+  default:
+    break;
+  }
+}
+
+void Sdeactivate_thread(void) { /* deactivate current thread */
+  ptr tc = get_thread_context();
+  if (tc != (ptr)0) deactivate_thread(tc)
+}
+
+int Sdestroy_thread(void) { /* destroy current thread */
+  ptr tc = get_thread_context();
+  if (tc != (ptr)0 && destroy_thread(tc)) {
+    s_thread_setspecific(S_tc_key, 0);
+    return 1;
+  }
+  return 0;
+}
+
+static IBOOL destroy_thread(ptr tc) {
+  ptr *ls; IBOOL status;
+
+  status = 0;
+  tc_mutex_acquire()
+  ls = &S_threads;
+  while (*ls != Snil) {
+    ptr thread = Scar(*ls);
+    if (THREADTC(thread) == (uptr)tc) {
+      *ls = Scdr(*ls);
+      S_nthreads -= 1;
+
+     /* process remembered set before dropping allocation area */
+      S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc));
+
+     /* process guardian entries */
+      {
+	ptr target, ges, obj, next; seginfo *si;
+	target = S_G.guardians[0];
+	for (ges = GUARDIANENTRIES(tc); ges != Snil; ges = next) {
+	  obj = GUARDIANOBJ(ges);
+	  next = GUARDIANNEXT(ges);
+	  if (!IMMEDIATE(obj) && (si = MaybeSegInfo(ptr_get_segment(obj))) != NULL && si->generation != static_generation) {
+	    INITGUARDIANNEXT(ges) = target;
+	    target = ges;
+	  }
+	}
+	S_G.guardians[0] = target;
+      }
+
+     /* deactivate thread */
+      if (ACTIVE(tc)) {
+        SETSYMVAL(S_G.active_threads_id,
+         FIX(UNFIX(SYMVAL(S_G.active_threads_id)) - 1));
+        if (Sboolean_value(SYMVAL(S_G.collect_request_pending_id))
+            && SYMVAL(S_G.active_threads_id) == FIX(0)) {
+          s_thread_cond_signal(&S_collect_cond);
+        }
+      }
+
+      if (LZ4OUTBUFFER(tc) != NULL) free(LZ4OUTBUFFER(tc));
+      if (SIGNALINTERRUPTQUEUE(tc) != NULL) free(SIGNALINTERRUPTQUEUE(tc));
+
+      free((void *)tc);
+      THREADTC(thread) = 0; /* mark it dead */
+      status = 1;
+      break;
+    }
+    ls = &Scdr(*ls);
+  }
+  tc_mutex_release()
+  return status;
+}
+
+ptr S_fork_thread(ptr thunk) {
+  ptr thread;
+  int status;
+
+  /* pass the current thread's context as the parent thread */
+  thread = S_create_thread_object("fork-thread", get_thread_context());
+  CP(THREADTC(thread)) = thunk;
+
+  if ((status = s_thread_create(start_thread, (void *)THREADTC(thread))) != 0) {
+    destroy_thread((ptr)THREADTC(thread));
+    S_error1("fork-thread", "failed: ~a", S_strerror(status));
+  }
+
+  return thread;
+}
+
+static s_thread_rv_t start_thread(p) void *p; {
+  ptr tc = (ptr)p; ptr cp;
+
+  s_thread_setspecific(S_tc_key, tc);
+
+  cp = CP(tc);
+  CP(tc) = Svoid; /* should hold calling code object, which we don't have */
+  TRAP(tc) = (ptr)default_timer_ticks;
+  Scall0(cp);
+ /* caution: calling into Scheme may result into a collection, so we
+    can't access any Scheme objects, e.g., cp, after this point.  But tc
+    is static, so we can access it. */
+
+ /* find and destroy our thread */
+  destroy_thread(tc);
+  s_thread_setspecific(S_tc_key, (ptr)0);
+
+  s_thread_return;
+}
+
+
+scheme_mutex_t *S_make_mutex() {
+  scheme_mutex_t *m;
+
+  m = (scheme_mutex_t *)malloc(sizeof(scheme_mutex_t));
+
+  if (m == (scheme_mutex_t *)0)
+    S_error("make-mutex", "unable to malloc mutex");
+  s_thread_mutex_init(&m->pmutex);
+  m->owner = s_thread_self();
+  m->count = 0;
+
+  return m;
+}
+
+void S_mutex_free(scheme_mutex_t *m) {
+  s_thread_mutex_destroy(&m->pmutex);
+  free(m);
+}
+
+void S_mutex_acquire(scheme_mutex_t *m) {
+  s_thread_t self = s_thread_self();
+  iptr count;
+  INT status;
+
+  if ((count = m->count) > 0 && s_thread_equal(m->owner, self)) {
+    if (count == most_positive_fixnum)
+      S_error1("mutex-acquire", "recursion limit exceeded for ~s", m);
+    m->count = count + 1;
+    return;
+  }
+    
+  if ((status = s_thread_mutex_lock(&m->pmutex)) != 0)
+    S_error1("mutex-acquire", "failed: ~a", S_strerror(status));
+  m->owner = self;
+  m->count = 1;
+}
+
+INT S_mutex_tryacquire(scheme_mutex_t *m) {
+  s_thread_t self = s_thread_self();
+  iptr count;
+  INT status;
+
+  if ((count = m->count) > 0 && s_thread_equal(m->owner, self)) {
+    if (count == most_positive_fixnum)
+      S_error1("mutex-acquire", "recursion limit exceeded for ~s", m);
+    m->count = count + 1;
+    return 0;
+  }
+
+  status = s_thread_mutex_trylock(&m->pmutex);
+  if (status == 0) {
+    m->owner = self;
+    m->count = 1;
+  } else if (status != EBUSY) {
+    S_error1("mutex-acquire", "failed: ~a", S_strerror(status));
+  }
+  return status;
+}
+
+void S_mutex_release(scheme_mutex_t *m) {
+  s_thread_t self = s_thread_self();
+  iptr count;
+  INT status;
+
+  if ((count = m->count) == 0 || !s_thread_equal(m->owner, self))
+    S_error1("mutex-release", "thread does not own mutex ~s", m);
+
+  if ((m->count = count - 1) == 0)
+    if ((status = s_thread_mutex_unlock(&m->pmutex)) != 0)
+      S_error1("mutex-release", "failed: ~a", S_strerror(status));
+}
+
+s_thread_cond_t *S_make_condition() {
+  s_thread_cond_t *c;
+
+  c = (s_thread_cond_t *)malloc(sizeof(s_thread_cond_t));
+  if (c == (s_thread_cond_t *)0)
+    S_error("make-condition", "unable to malloc condition");
+  s_thread_cond_init(c);
+  return c;
+}
+
+void S_condition_free(s_thread_cond_t *c) {
+  s_thread_cond_destroy(c);
+  free(c);
+}
+
+#ifdef FEATURE_WINDOWS
+
+static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, I64 sec, long nsec) {
+  if (typeno == time_utc) {
+    struct timespec now;
+    S_gettime(time_utc, &now);
+    sec -= now.tv_sec;
+    nsec -= now.tv_nsec;
+    if (nsec < 0) {
+      sec -= 1;
+      nsec += 1000000000;
+    }
+  }
+  if (sec < 0) {
+    sec = 0;
+    nsec = 0;
+  }
+  if (SleepConditionVariableCS(cond, mutex, (DWORD)(sec*1000 + (nsec+500000)/1000000))) {
+    return 0;
+  } else if (GetLastError() == ERROR_TIMEOUT) {
+    return ETIMEDOUT;
+  } else {
+    return EINVAL;
+  }
+}
+
+#else /* FEATURE_WINDOWS */
+
+static inline int s_thread_cond_timedwait(s_thread_cond_t *cond, s_thread_mutex_t *mutex, int typeno, I64 sec, long nsec) {
+  struct timespec t;
+  if (typeno == time_duration) {
+    struct timespec now;
+    S_gettime(time_utc, &now);
+    t.tv_sec = (time_t)(now.tv_sec + sec);
+    t.tv_nsec = now.tv_nsec + nsec;
+    if (t.tv_nsec >= 1000000000) {
+      t.tv_sec += 1;
+      t.tv_nsec -= 1000000000;
+    }
+  } else {
+    t.tv_sec = sec;
+    t.tv_nsec = nsec;
+  }
+  return pthread_cond_timedwait(cond, mutex, &t);
+}
+
+#endif /* FEATURE_WINDOWS */
+
+#define Srecord_ref(x,i) (((ptr *)((uptr)(x)+record_data_disp))[i])
+
+IBOOL S_condition_wait(s_thread_cond_t *c, scheme_mutex_t *m, ptr t) {
+  ptr tc = get_thread_context();
+  s_thread_t self = s_thread_self();
+  iptr count;
+  INT typeno;
+  I64 sec;
+  long nsec;
+  INT status;
+
+  if ((count = m->count) == 0 || !s_thread_equal(m->owner, self))
+    S_error1("condition-wait", "thread does not own mutex ~s", m);
+
+  if (count != 1)
+    S_error1("condition-wait", "mutex ~s is recursively locked", m);
+
+  if (t != Sfalse) {
+    /* Keep in sync with ts record in s/date.ss */
+    typeno = Sinteger32_value(Srecord_ref(t,0));
+    sec = Sinteger64_value(Scar(Srecord_ref(t,1)));
+    nsec = Sinteger32_value(Scdr(Srecord_ref(t,1)));
+  } else {
+    typeno = 0;
+    sec = 0;
+    nsec = 0;
+  }
+
+  if (c == &S_collect_cond || DISABLECOUNT(tc) == 0) {
+    deactivate_thread(tc)
+  }
+
+  m->count = 0;
+  status = (t == Sfalse) ? s_thread_cond_wait(c, &m->pmutex) :
+    s_thread_cond_timedwait(c, &m->pmutex, typeno, sec, nsec);
+  m->owner = self;
+  m->count = 1;
+
+  if (c == &S_collect_cond || DISABLECOUNT(tc) == 0) {
+    reactivate_thread(tc)
+  }
+
+  if (status == 0) {
+    return 1;
+  } else if (status == ETIMEDOUT) {
+    return 0;
+  } else {
+    S_error1("condition-wait", "failed: ~a", S_strerror(status));
+    return 0;
+  }
+}
+#endif /* PTHREADS */
+

ta6ob/c/thread.h

@@ -0,0 +1,91 @@
+/* thread.h
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#ifdef FEATURE_PTHREADS
+#ifdef FEATURE_WINDOWS
+
+#include <process.h>
+#include <time.h>
+
+/* learned from http://locklessinc.com/articles/pthreads_on_windows/ which
+ * Windows API types and functions to use to support mutexes and condition
+ * variables.  there's much more information there if we ever need a more
+ * complete implementation of pthreads functionality.
+ */
+
+typedef DWORD s_thread_t;
+typedef DWORD s_thread_key_t;
+typedef CRITICAL_SECTION s_thread_mutex_t;
+typedef CONDITION_VARIABLE s_thread_cond_t;
+typedef void s_thread_rv_t;
+#define s_thread_return return
+#define s_thread_self() GetCurrentThreadId()
+#define s_thread_equal(t1, t2) ((t1) == (t2))
+/* CreateThread description says to use _beginthread if thread uses the C library */
+#define s_thread_create(start_routine, arg) (_beginthread(start_routine, 0, arg) == -1 ? EAGAIN : 0)
+#define s_thread_key_create(key) ((*key = TlsAlloc()) == TLS_OUT_OF_INDEXES ? EAGAIN : 0)
+#define s_thread_key_delete(key) (TlsFree(key) == 0 ? EINVAL : 0)
+#define s_thread_getspecific(key) TlsGetValue(key)
+#define s_thread_setspecific(key, value) (TlsSetValue(key, (void *)value) == 0 ? EINVAL : 0)
+#define s_thread_mutex_init(mutex) InitializeCriticalSection(mutex)
+#define s_thread_mutex_lock(mutex) (EnterCriticalSection(mutex), 0)
+#define s_thread_mutex_unlock(mutex) (LeaveCriticalSection(mutex), 0)
+#define s_thread_mutex_trylock(mutex) (TryEnterCriticalSection(mutex) ? 0 : EBUSY)
+#define s_thread_mutex_destroy(mutex) (DeleteCriticalSection(mutex), 0)
+#define s_thread_cond_init(cond) InitializeConditionVariable(cond)
+#define s_thread_cond_signal(cond) (WakeConditionVariable(cond), 0)
+#define s_thread_cond_broadcast(cond) (WakeAllConditionVariable(cond), 0)
+#define s_thread_cond_wait(cond, mutex) (SleepConditionVariableCS(cond, mutex, INFINITE) == 0 ? EINVAL : 0)
+#define s_thread_cond_destroy(cond) (0)
+
+#else /* FEATURE_WINDOWS */
+
+#include <pthread.h>
+
+typedef pthread_t s_thread_t;
+typedef pthread_key_t s_thread_key_t;
+typedef pthread_mutex_t s_thread_mutex_t;
+typedef pthread_cond_t s_thread_cond_t;
+typedef void *s_thread_rv_t;
+#define s_thread_return return NULL
+#define s_thread_self() pthread_self()
+#define s_thread_equal(t1, t2) pthread_equal(t1, t2)
+static inline int s_thread_create(void *(* start_routine)(void *), void *arg) {
+  pthread_attr_t attr; pthread_t thread; int status;
+
+  pthread_attr_init(&attr);
+  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
+  status = pthread_create(&thread, &attr, start_routine, arg);
+  pthread_attr_destroy(&attr);
+  return status;
+}
+#define s_thread_key_create(key) pthread_key_create(key, NULL)
+#define s_thread_key_delete(key) pthread_key_delete(key)
+#define s_thread_getspecific(key) pthread_getspecific(key)
+#define s_thread_setspecific(key, value) pthread_setspecific(key, value)
+#define s_thread_mutex_init(mutex) pthread_mutex_init(mutex, NULL)
+#define s_thread_mutex_lock(mutex) pthread_mutex_lock(mutex)
+#define s_thread_mutex_unlock(mutex) pthread_mutex_unlock(mutex)
+#define s_thread_mutex_trylock(mutex) pthread_mutex_trylock(mutex)
+#define s_thread_mutex_destroy(mutex) pthread_mutex_destroy(mutex)
+#define s_thread_cond_init(cond) pthread_cond_init(cond, NULL)
+#define s_thread_cond_signal(cond) pthread_cond_signal(cond)
+#define s_thread_cond_broadcast(cond) pthread_cond_broadcast(cond)
+#define s_thread_cond_wait(cond, mutex) pthread_cond_wait(cond, mutex)
+#define s_thread_cond_destroy(cond) pthread_cond_destroy(cond)
+
+#endif /* FEATURE_WINDOWS */
+#endif /* FEATURE_PTHREADS */

ta6ob/c/types.h

@@ -0,0 +1,381 @@
+/* types.h
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+/* C datatypes (mostly defined in equates.h or scheme.h)
+ *    ptr: scheme object: (void *) on most platforms
+ *   uptr: unsigned integer sizeof(uptr) == sizeof(ptr): typically unsigned long
+ *   iptr: signed integer sizeof(uptr) == sizeof(ptr): typically long
+ *     I8: 8-bit signed integer: typically char
+ *    I16: 16-bit signed integer: typically short
+ *    I32: 32-bit signed integer: typically int
+ *    U32: 32-bit unsigned integer: typically unsigned int
+ *    I64: 64-bit signed integer: typically long long
+ *    U64: 64-bit unsigned integer: typically unsigned long long
+ *  bigit: unsigned integer sizeof(bigit)*8 == bigit_bits
+ *  bigit: unsigned integer sizeof(bigit)*8 == bigit_bits
+ */
+
+#if (bigit_bits == 32)
+typedef U32 bigit;
+typedef U64 bigitbigit;
+typedef I32 ibigit;
+typedef I64 ibigitbigit;
+#endif
+
+/* C signed/unsigned conventions:
+ *  signed/unsigned distinction is felt in comparisons with zero, right
+ *  shifts, multiplies, and divides.
+ *
+ *  general philosophy is to avoid surprises by using signed quantities,
+ *  with a few exceptions.
+ *
+ *  use unsigned whenever shifting right.  ANSI C >> is undefined for
+ *  negative numbers.  if arithmetic shift is desired, divide by the
+ *  appropriate power of two and hope that the C compiler generates a
+ *  shift instruction.
+ *
+ *  cast to uptr for ptr address computations.  this is really necessary
+ *  only when shifting addresses, but we do it all the time since
+ *  addresses are inherently unsigned values.
+ *
+ *  however, use signed (usually iptr) for lengths and array indices.
+ *  this allows base cases like i < 0 when working backward from the end
+ *  to the front of an array.  using uptr would give a slightly larger
+ *  range in theory, but not in practice.
+ */
+
+/* documentary names for ints and unsigned ints */
+typedef int INT;            /* honest-to-goodness C int */
+typedef unsigned int UINT;  /* honest-to-goodness C unsigned int */
+typedef int ITYPE;          /* ptr types */
+typedef int ISPC;           /* storage manager spaces */
+typedef int IGEN;           /* storage manager generations */
+typedef int IDIRTYBYTE;     /* storage manager dirty bytes */
+typedef int IBOOL;          /* int used exclusively as a boolean */
+typedef int ICHAR;          /* int used exclusively as a character */
+typedef int IFASLCODE;      /* fasl type codes */
+
+#if (BUFSIZ < 4096)
+#define SBUFSIZ 4096
+#else
+#define SBUFSIZ BUFSIZ
+#endif
+
+/* inline allocation --- mutex required */
+/* find room allocates n bytes in space s and generation g into
+ * destination x, tagged with ty, punting to find_more_room if
+ * no space is left in the current segment.  n is assumed to be
+ * an integral multiple of the object alignment. */
+#define find_room(s, g, t, n, x) {\
+    ptr X = S_G.next_loc[g][s];\
+    S_G.next_loc[g][s] = (ptr)((uptr)X + (n));\
+    if ((S_G.bytes_left[g][s] -= (n)) < 0) X = S_find_more_room(s, g, n, X);\
+    (x) = TYPE(X, t);\
+}
+
+/* thread-local inline allocation --- no mutex required */
+/* thread_find_room allocates n bytes in the local allocation area of
+ * the thread (hence space new, generation zero) into destination x, tagged
+ * with type t, punting to find_more_room if no space is left in the current
+ * allocation area.  n is assumed to be an integral multiple of the object
+ * alignment. */
+#define thread_find_room(tc, t, n, x) {\
+  ptr _tc = tc;\
+  uptr _ap = (uptr)AP(_tc);\
+  if ((uptr)n > ((uptr)EAP(_tc) - _ap)) {\
+    (x) = S_get_more_room_help(_tc, _ap, t, n);\
+  } else {\
+    (x) = TYPE(_ap,t);\
+    AP(_tc) = (ptr)(_ap + n);\
+  }\
+}
+
+/* size of protected array used to store roots for the garbage collector */
+#define max_protected 100
+
+#define build_ptr(s,o) ((ptr)(((uptr)(s) << segment_offset_bits) | (uptr)(o)))
+#define addr_get_segment(p) ((uptr)(p) >> segment_offset_bits)
+#define ptr_get_segment(p) (((uptr)(p) + typemod - 1) >> segment_offset_bits)
+
+#define SPACE(p) SegmentSpace(ptr_get_segment(p))
+#define GENERATION(p) SegmentGeneration(ptr_get_segment(p))
+
+#define ptr_align(size) (((size)+byte_alignment-1) & ~(byte_alignment-1))
+
+typedef struct _seginfo {
+  unsigned char space;                      /* space the segment is in */
+  unsigned char generation;                 /* generation the segment is in */
+  unsigned char sorted;                     /* sorted indicator---possibly to be incorporated into space flags? */
+  octet min_dirty_byte;                     /* dirty byte for full segment, effectively min(dirty_bytes) */
+  uptr number;                              /* the segment number */
+  struct _chunkinfo *chunk;                 /* the chunk this segment belongs to */
+  struct _seginfo *next;                    /* pointer to the next seginfo (used in occupied_segments and unused_segs */
+  struct _seginfo **dirty_prev;             /* pointer to the next pointer on the previous seginfo in the DirtySegments list */
+  struct _seginfo *dirty_next;              /* pointer to the next seginfo on the DirtySegments list */
+  ptr trigger_ephemerons;                   /* ephemerons to re-check if object in segment is copied out */
+  octet dirty_bytes[cards_per_segment];     /* one dirty byte per card */
+} seginfo;
+
+typedef struct _chunkinfo {
+  void *addr;                               /* chunk starting address */
+  iptr base;                                /* first segment */
+  iptr bytes;                               /* size in bytes */
+  iptr segs;                                /* size in segments */
+  iptr nused_segs;                          /* number of segments currently in used use */ 
+  struct _chunkinfo **prev;                 /* pointer to previous chunk's next */
+  struct _chunkinfo *next;                  /* next chunk */
+  struct _seginfo *unused_segs;             /* list of unused segments */
+  struct _seginfo sis[0];                   /* one seginfo per segment */
+} chunkinfo;
+
+#ifdef segment_t2_bits
+typedef struct _t1table {
+  seginfo *t1[1<<segment_t1_bits];         /* table first to reduce access cost */
+  iptr refcount;                           /* refcount last, since it's rarely accessed */
+} t1table;
+#ifdef segment_t3_bits
+typedef struct _t2table {
+  t1table *t2[1<<segment_t2_bits];         /* table first to reduce access cost */
+  iptr refcount;                           /* refcount last, since it's rarely accessed */
+} t2table;
+#endif /* segment_t3_bits */
+#endif /* segment_t2_bits */
+
+/* CHUNK_POOLS determines the number of bins into which find_segment sorts chunks with
+   varying lengths of empty segment chains.  it must be at least 1. */
+#define PARTIAL_CHUNK_POOLS 8
+
+/* dirty list table is conceptually a two-dimensional gen x gen table,
+   but we use only the to_g entries for 0..from_g - 1.  say
+   static_generation were 5 instead of 255, we don't need the 'X'
+   entries in the table below, and they would clutter up our cache lines:
+
+                     to_g
+          0     1     2     3     4     5
+       +-----+-----+-----+-----+-----+-----+
+    0  |  X  |  X  |  X  |  X  |  X  |  X  |
+       +-----+-----+-----+-----+-----+-----+
+    1  |     |  X  |  X  |  X  |  X  |  X  |
+       +-----+-----+-----+-----+-----+-----+
+    2  |     |     |  X  |  X  |  X  |  X  |
+       +-----+-----+-----+-----+-----+-----+
+    3  |     |     |     |  X  |  X  |  X  |
+       +-----+-----+-----+-----+-----+-----+
+    4  |     |     |     |     |  X  |  X  |
+       +-----+-----+-----+-----+-----+-----+
+    5  |     |     |     |     |     |  X  |
+       +-----+-----+-----+-----+-----+-----+
+
+   so we create a vector instead of a matrix and roll our own version
+   of row-major order.
+
+       +-----+-----+-----+-----+----
+       | 1,0 | 2,0 | 2,1 | 3,0 | ...
+       +-----+-----+-----+-----+----
+
+   any entry from_g, to_g can be found at from_g*(from_g-1)/2+to_g.
+*/
+
+#define DIRTY_SEGMENT_INDEX(from_g, to_g) ((((unsigned)((from_g)*((from_g)-1)))>>1)+to_g)
+#define DIRTY_SEGMENT_LISTS DIRTY_SEGMENT_INDEX(static_generation, static_generation)
+
+#define DirtySegments(from_g, to_g) S_G.dirty_segments[DIRTY_SEGMENT_INDEX(from_g, to_g)]
+
+/* oblist */
+
+typedef struct _bucket {
+  ptr sym;
+  struct _bucket *next;
+} bucket;
+
+typedef struct _bucket_list {
+  struct _bucket *car;
+  struct _bucket_list *cdr;
+} bucket_list;
+
+typedef struct _bucket_pointer_list {
+  struct _bucket **car;
+  struct _bucket_pointer_list *cdr;
+} bucket_pointer_list;
+
+/* size macros for variable-sized objects */
+
+#define size_vector(n) ptr_align(header_size_vector + (n)*ptr_bytes)
+#define size_closure(n) ptr_align(header_size_closure + (n)*ptr_bytes)
+#define size_string(n) ptr_align(header_size_string + (n)*string_char_bytes)
+#define size_fxvector(n) ptr_align(header_size_fxvector + (n)*ptr_bytes)
+#define size_bytevector(n) ptr_align(header_size_bytevector + (n))
+#define size_bignum(n) ptr_align(header_size_bignum + (n)*bigit_bytes)
+#define size_code(n) ptr_align(header_size_code + (n))
+#define size_reloc_table(n) ptr_align(header_size_reloc_table + (n)*ptr_bytes)
+#define size_record_inst(n) ptr_align(n)
+#define unaligned_size_record_inst(n) (n)
+
+/* type tagging macros */
+
+#define TYPE(x,type) ((ptr)((iptr)(x) - typemod + (type)))
+#define UNTYPE(x,type) ((ptr)((iptr)(x) + typemod - (type)))
+#define UNTYPE_ANY(x) ((ptr)(((iptr)(x) + (typemod - 1)) & ~(typemod - 1)))
+#define TYPEBITS(x) ((iptr)(x) & (typemod - 1))
+#define TYPEFIELD(x) (*(ptr *)UNTYPE(x, type_typed_object))
+
+#define FIX(x) Sfixnum(x)
+#define UNFIX(x) Sfixnum_value(x)
+
+#define TYPEP(x,mask,type) (((iptr)(x) & (mask)) == (type))
+
+/* reloc fields */
+#define RELOC_EXTENDED_FORMAT(x) ((x)&reloc_extended_format)
+#define RELOC_TYPE(x) (((x)>>reloc_type_offset)&reloc_type_mask)
+#define RELOC_CODE_OFFSET(x) (((x)>>reloc_code_offset_offset)&reloc_code_offset_mask)
+#define RELOC_ITEM_OFFSET(x) (((x)>>reloc_item_offset_offset)&reloc_item_offset_mask)
+#define MAKE_SHORT_RELOC(ty,co,io) (((ty)<<reloc_type_offset)|((co)<<reloc_code_offset_offset)|((io)<<reloc_item_offset_offset))
+
+/* derived type predicates */
+
+#define GENSYMP(x) (Ssymbolp(x) && (!Sstringp(SYMNAME(x))))
+#define FIXRANGE(x) ((uptr)((x) - most_negative_fixnum) <= (uptr)(most_positive_fixnum - most_negative_fixnum))
+/* this breaks gcc 2.96
+#define FIXRANGE(x) (Sfixnum_value(Sfixnum(x)) == x)
+*/
+
+#define DIRTYSET(lhs,rhs) S_dirty_set(lhs, rhs);
+
+/* derived accessors/constructors */
+#define FWDMARKER(p) FORWARDMARKER((uptr)UNTYPE_ANY(p))
+#define FWDADDRESS(p) FORWARDADDRESS((uptr)UNTYPE_ANY(p))
+
+#define ENTRYFRAMESIZE(x) RPHEADERFRAMESIZE((uptr)(x) - size_rp_header)
+#define ENTRYOFFSET(x) RPHEADERTOPLINK((uptr)(x) - size_rp_header)
+#define ENTRYLIVEMASK(x) RPHEADERLIVEMASK((uptr)(x) - size_rp_header)
+
+#define PORTFD(x) ((iptr)PORTHANDLER(x))
+#define PORTGZFILE(x) ((gzFile)(PORTHANDLER(x)))
+
+#define CAAR(x) Scar(Scar(x))
+#define CADR(x) Scar(Scdr(x))
+#define CDAR(x) Scdr(Scar(x))
+#define LIST1(x) Scons(x, Snil)
+#define LIST2(x,y) Scons(x, LIST1(y))
+#define LIST3(x,y,z) Scons(x, LIST2(y, z))
+#define LIST4(x,y,z,w) Scons(x, LIST3(y, z, w))
+
+#define REGARG(tc,i) ARGREG(tc,(i)-1)
+#define FRAME(tc,i) (((ptr *)SFP(tc))[i])
+
+#ifdef PTHREADS
+typedef struct {
+  volatile s_thread_t owner;
+  volatile uptr count;
+  s_thread_mutex_t pmutex;
+} scheme_mutex_t;
+
+#define get_thread_context() (ptr)s_thread_getspecific(S_tc_key)
+/* deactivate thread prepares the thread for a possible collection.
+   if it's the last active thread, it signals one of the threads
+   waiting on the collect condition, if any, so that a collection
+   can proceed.  if we happen to be the collecting thread, the active
+   thread count is zero, in which case we don't signal.  collection
+   is not permitted to happen when interrupts are disabled, so we
+   don't let anything happen in that case. */
+#define deactivate_thread(tc) {\
+  if (ACTIVE(tc)) {\
+    ptr code;\
+    tc_mutex_acquire()\
+    code = CP(tc);\
+    if (Sprocedurep(code)) CP(tc) = code = CLOSCODE(code);\
+    Slock_object(code);\
+    SETSYMVAL(S_G.active_threads_id,\
+     FIX(UNFIX(SYMVAL(S_G.active_threads_id)) - 1));\
+    if (Sboolean_value(SYMVAL(S_G.collect_request_pending_id))\
+        && SYMVAL(S_G.active_threads_id) == FIX(0)) {\
+      s_thread_cond_signal(&S_collect_cond);\
+    }\
+    ACTIVE(tc) = 0;\
+    tc_mutex_release()\
+  }\
+}
+#define reactivate_thread(tc) {\
+  if (!ACTIVE(tc)) {\
+    tc_mutex_acquire()\
+    SETSYMVAL(S_G.active_threads_id,\
+     FIX(UNFIX(SYMVAL(S_G.active_threads_id)) + 1));\
+    Sunlock_object(CP(tc));\
+    ACTIVE(tc) = 1;\
+    tc_mutex_release()\
+  }\
+}
+/* S_tc_mutex_depth records the number of nested mutex acquires in
+   C code on tc_mutex.  it is used by do_error to release tc_mutex
+   the appropriate number of times.
+*/
+#define tc_mutex_acquire() {\
+  S_mutex_acquire(&S_tc_mutex);\
+  S_tc_mutex_depth += 1;\
+}
+#define tc_mutex_release() {\
+  S_tc_mutex_depth -= 1;\
+  S_mutex_release(&S_tc_mutex);\
+}
+#else
+#define get_thread_context() (ptr)S_G.thread_context
+#define deactivate_thread(tc) {}
+#define reactivate_thread(tc) {}
+#define tc_mutex_acquire() {}
+#define tc_mutex_release() {}
+#endif
+
+#ifdef __MINGW32__
+/* With MinGW on 64-bit Windows, setjmp/longjmp is not reliable. Using
+   __builtin_setjmp/__builtin_longjmp is reliable, but
+   __builtin_longjmp requires 1 as its second argument. So, allocate
+   room in the buffer for a return value. */
+# define JMPBUF_RET(jb) (*(int *)((char *)(jb)+sizeof(jmp_buf)))
+# define CREATEJMPBUF() malloc(sizeof(jmp_buf)+sizeof(int))
+# define FREEJMPBUF(jb) free(jb)
+# define SETJMP(jb) (JMPBUF_RET(jb) = 0, __builtin_setjmp(jb), JMPBUF_RET(jb))
+# define LONGJMP(jb,n) (JMPBUF_RET(jb) = n, __builtin_longjmp(jb, 1))
+#else
+# ifdef _WIN64
+#  define CREATEJMPBUF() malloc(256)
+#  define SETJMP(jb) S_setjmp(jb)
+#  define LONGJMP(jb,n) S_longjmp(jb, n)
+# else
+/* assuming malloc will give us required alignment */
+#  define CREATEJMPBUF() malloc(sizeof(jmp_buf))
+#  define SETJMP(jb) _setjmp(jb)
+#  define LONGJMP(jb,n) _longjmp(jb, n)
+# endif
+# define FREEJMPBUF(jb) free(jb)
+#endif
+
+#define DOUNDERFLOW\
+ &CODEIT(CLOSCODE(S_lookup_library_entry(library_dounderflow, 1)),size_rp_header)
+
+#define HEAP_VERSION_LENGTH 16
+#define HEAP_MACHID_LENGTH 16
+#define HEAP_STAMP_LENGTH 16
+
+/* keep MAKE_FD in sync with io.ss make-fd */
+#define MAKE_FD(fd) Sinteger(fd)
+#define GET_FD(file) ((INT)Sinteger_value(file))
+
+#define PTRFIELD(x,disp) (*(ptr *)((uptr)(x)+disp))
+#define INITPTRFIELD(x,disp) (*(ptr *)((uptr)(x)+disp))
+#define SETPTRFIELD(x,disp,y) DIRTYSET(((ptr *)((uptr)(x)+disp)),(y))
+
+#define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1)
+#define IMMEDIATE(x) (Sfixnump(x) || Simmediatep(x))

ta6ob/c/version.h

@@ -0,0 +1,457 @@
+/* version.h
+ * Copyright 1984-2017 Cisco Systems, Inc.
+ * 
+ * Licensed under the Apache License, Version 2.0 (the "License");
+ * you may not use this file except in compliance with the License.
+ * You may obtain a copy of the License at
+ * 
+ * http://www.apache.org/licenses/LICENSE-2.0
+ * 
+ * Unless required by applicable law or agreed to in writing, software
+ * distributed under the License is distributed on an "AS IS" BASIS,
+ * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ * See the License for the specific language governing permissions and
+ * limitations under the License.
+ */
+
+#include "config.h"
+
+#if (machine_type == machine_type_arm32le || machine_type == machine_type_tarm32le || machine_type == machine_type_arm64le || machine_type == machine_type_tarm64le)
+#if (machine_type == machine_type_tarm32le || machine_type == machine_type_tarm64le)
+#define PTHREADS
+#endif
+#define NOBLOCK O_NONBLOCK
+#define LOAD_SHARED_OBJECT
+#define USE_MMAP
+#define MMAP_HEAP
+#define IEEE_DOUBLE
+#define LITTLE_ENDIAN_IEEE_DOUBLE
+#define LDEXP
+#define ARCHYPERBOLIC
+#define GETPAGESIZE() getpagesize()
+typedef char *memcpy_t;
+#define MAKE_NAN(x) { x = 0.0; x = x / x; }
+#define GETWD(x) getcwd((x),PATH_MAX)
+typedef int tputsputcchar;
+#define LOCKF
+#define DIRMARKERP(c) ((c) == '/')
+#define FLUSHCACHE
+#ifndef DISABLE_X11
+#define LIBX11 "libX11.so"
+#endif
+#define LSEEK lseek64
+#define OFF_T off64_t
+#define _LARGEFILE64_SOURCE
+#define SECATIME(sb) (sb).st_atim.tv_sec
+#define SECCTIME(sb) (sb).st_ctim.tv_sec
+#define SECMTIME(sb) (sb).st_mtim.tv_sec
+#define NSECATIME(sb) (sb).st_atim.tv_nsec
+#define NSECCTIME(sb) (sb).st_ctim.tv_nsec
+#define NSECMTIME(sb) (sb).st_mtim.tv_nsec
+#define ICONV_INBUF_TYPE char **
+#define UNUSED __attribute__((__unused__))
+#endif
+
+#if (machine_type == machine_type_ppc32le || machine_type == machine_type_tppc32le || machine_type == machine_type_ppc64le || machine_type == machine_type_tppc64le)
+#if (machine_type == machine_type_tppc32le || machine_type == machine_type_tppc64le)
+#define PTHREADS
+#endif
+#define NOBLOCK O_NONBLOCK
+#define LOAD_SHARED_OBJECT
+#define USE_MMAP
+#define MMAP_HEAP
+#define IEEE_DOUBLE
+#define LDEXP
+#define ARCHYPERBOLIC
+#define GETPAGESIZE() getpagesize()
+typedef char *memcpy_t;
+#define MAKE_NAN(x) { x = 0.0; x = x / x; }
+#define GETWD(x) getcwd((x),PATH_MAX)
+typedef int tputsputcchar;
+#define LOCKF
+#define DIRMARKERP(c) ((c) == '/')
+#define FLUSHCACHE
+#ifndef DISABLE_X11
+#define LIBX11 "libX11.so"
+#endif
+#define LSEEK lseek64
+#define OFF_T off64_t
+#define _LARGEFILE64_SOURCE
+#define SECATIME(sb) (sb).st_atim.tv_sec
+#define SECCTIME(sb) (sb).st_ctim.tv_sec
+#define SECMTIME(sb) (sb).st_mtim.tv_sec
+#define NSECATIME(sb) (sb).st_atim.tv_nsec
+#define NSECCTIME(sb) (sb).st_ctim.tv_nsec
+#define NSECMTIME(sb) (sb).st_mtim.tv_nsec
+#define ICONV_INBUF_TYPE char **
+#define UNUSED __attribute__((__unused__))
+#endif
+
+#if (machine_type == machine_type_i3le || machine_type == machine_type_ti3le || machine_type == machine_type_a6le || machine_type == machine_type_ta6le)
+#if (machine_type == machine_type_ti3le || machine_type == machine_type_ta6le)
+#define PTHREADS
+#endif
+#define NOBLOCK O_NONBLOCK
+#define LOAD_SHARED_OBJECT
+#define USE_MMAP
+#define MMAP_HEAP
+#define IEEE_DOUBLE
+#define LITTLE_ENDIAN_IEEE_DOUBLE
+#define LDEXP
+#define ARCHYPERBOLIC
+#define GETPAGESIZE() getpagesize()
+typedef char *memcpy_t;
+#define MAKE_NAN(x) { x = 0.0; x = x / x; }
+#define GETWD(x) getcwd((x),PATH_MAX)
+typedef int tputsputcchar;
+#define LOCKF
+#define DIRMARKERP(c) ((c) == '/')
+#ifndef DISABLE_X11
+#define LIBX11 "libX11.so"
+#endif
+#define LSEEK lseek64
+#define OFF_T off64_t
+#define _LARGEFILE64_SOURCE
+#define SECATIME(sb) (sb).st_atim.tv_sec
+#define SECCTIME(sb) (sb).st_ctim.tv_sec
+#define SECMTIME(sb) (sb).st_mtim.tv_sec
+#define NSECATIME(sb) (sb).st_atim.tv_nsec
+#define NSECCTIME(sb) (sb).st_ctim.tv_nsec
+#define NSECMTIME(sb) (sb).st_mtim.tv_nsec
+#define ICONV_INBUF_TYPE char **
+#define UNUSED __attribute__((__unused__))
+#endif
+
+#if (machine_type == machine_type_i3fb || machine_type == machine_type_ti3fb || machine_type == machine_type_a6fb || machine_type == machine_type_ta6fb)
+#if (machine_type == machine_type_ti3fb || machine_type == machine_type_ta6fb)
+#define PTHREADS
+#endif
+#define NOBLOCK O_NONBLOCK
+#define LOAD_SHARED_OBJECT
+#define USE_MMAP
+#define MMAP_HEAP
+#define IEEE_DOUBLE
+#define LITTLE_ENDIAN_IEEE_DOUBLE
+#define LDEXP
+#define ARCHYPERBOLIC
+#define GETPAGESIZE() getpagesize()
+typedef char *memcpy_t;
+#define MAKE_NAN(x) { x = 0.0; x = x / x; }
+#define GETWD(x) getcwd((x),PATH_MAX)
+typedef int tputsputcchar;
+#define LOCKF
+#define DIRMARKERP(c) ((c) == '/')
+#ifndef DISABLE_X11
+#define LIBX11 "libX11.so"
+#endif
+#define SECATIME(sb) (sb).st_atimespec.tv_sec
+#define SECCTIME(sb) (sb).st_ctimespec.tv_sec
+#define SECMTIME(sb) (sb).st_mtimespec.tv_sec
+#define NSECATIME(sb) (sb).st_atimespec.tv_nsec
+#define NSECCTIME(sb) (sb).st_ctimespec.tv_nsec
+#define NSECMTIME(sb) (sb).st_mtimespec.tv_nsec
+#define ICONV_INBUF_TYPE char **
+#define UNUSED __attribute__((__unused__))
+#define USE_OSSP_UUID
+#endif
+
+#if (machine_type == machine_type_i3nb || machine_type == machine_type_ti3nb || machine_type == machine_type_a6nb || machine_type == machine_type_ta6nb)
+#if (machine_type == machine_type_ti3nb || machine_type == machine_type_ta6nb)
+#define NETBSD
+#define PTHREADS
+#endif
+#define NOBLOCK O_NONBLOCK
+#define LOAD_SHARED_OBJECT
+#define USE_MMAP
+#define MMAP_HEAP
+#define IEEE_DOUBLE
+#define LITTLE_ENDIAN_IEEE_DOUBLE
+#define LDEXP
+#define ARCHYPERBOLIC
+#define GETPAGESIZE() getpagesize()
+typedef char *memcpy_t;
+struct timespec;
+#define MAKE_NAN(x) { x = 0.0; x = x / x; }
+#define GETWD(x) getcwd((x),PATH_MAX)
+typedef int tputsputcchar;
+#define LOCKF
+#define DIRMARKERP(c) ((c) == '/')
+#ifndef DISABLE_X11
+#define LIBX11 "libX11.so"
+#endif
+#define SECATIME(sb) (sb).st_atimespec.tv_sec
+#define SECCTIME(sb) (sb).st_ctimespec.tv_sec
+#define SECMTIME(sb) (sb).st_mtimespec.tv_sec
+#define NSECATIME(sb) (sb).st_atimespec.tv_nsec
+#define NSECCTIME(sb) (sb).st_ctimespec.tv_nsec
+#define NSECMTIME(sb) (sb).st_mtimespec.tv_nsec
+#define ICONV_INBUF_TYPE const char **
+#define UNUSED __attribute__((__unused__))
+#define USE_NETBSD_UUID
+#define USE_MBRTOWC_L
+#endif
+
+#if (machine_type == machine_type_i3nt || machine_type == machine_type_ti3nt || machine_type == machine_type_a6nt || machine_type == machine_type_ta6nt)
+#if (machine_type == machine_type_ti3nt || machine_type == machine_type_ta6nt)
+#define PTHREADS
+#endif
+#define GETPAGESIZE() S_getpagesize()
+#define GETWD(x) GETCWD(x, _MAX_PATH)
+#define IEEE_DOUBLE
+#define LITTLE_ENDIAN_IEEE_DOUBLE
+#define LOAD_SHARED_OBJECT
+#define USE_VIRTUAL_ALLOC
+#define NAN_INCLUDE <math.h>
+#define MAKE_NAN(x) { x = sqrt(-1.0); }
+#ifndef PATH_MAX
+# define PATH_MAX _MAX_PATH
+#endif
+typedef char *memcpy_t;
+struct timespec;
+#ifndef __MINGW32__
+# define _setjmp setjmp
+# define _longjmp longjmp
+# define ftruncate _chsize_s
+#endif
+#define LOCK_SH 1
+#define LOCK_EX 2
+#define LOCK_NB 4
+#define LOCK_UN 8
+#define FLOCK S_windows_flock
+#define DIRMARKERP(c) ((c) == '/' || (c) == '\\')
+#define CHDIR S_windows_chdir
+#define CHMOD S_windows_chmod
+#define CLOSE _close
+#define DUP _dup
+#define FILENO _fileno
+#define FSTAT _fstat64
+#define GETCWD S_windows_getcwd
+#define GETPID _getpid
+#define HYPOT _hypot
+#define LSEEK _lseeki64
+#define LSTAT S_windows_stat64
+#define OFF_T __int64
+#define OPEN S_windows_open
+#define READ _read
+#define RENAME S_windows_rename
+#define RMDIR S_windows_rmdir
+#define STAT S_windows_stat64
+#define STATBUF _stat64
+#define SYSTEM S_windows_system
+#define UNLINK S_windows_unlink
+#define WRITE _write
+#define SECATIME(sb) (sb).st_atime
+#define SECCTIME(sb) (sb).st_ctime
+#define SECMTIME(sb) (sb).st_mtime
+#define NSECATIME(sb) 0
+#define NSECCTIME(sb) 0
+#define NSECMTIME(sb) 0
+#define ICONV_INBUF_TYPE char **
+struct timespec;
+#define UNUSED
+#endif
+
+#if (machine_type == machine_type_i3ob || machine_type == machine_type_ti3ob || machine_type == machine_type_a6ob || machine_type == machine_type_ta6ob)
+#if (machine_type == machine_type_ti3ob || machine_type == machine_type_ta6ob)
+#define PTHREADS
+#endif
+#define NOBLOCK O_NONBLOCK
+#define LOAD_SHARED_OBJECT
+#define USE_MMAP
+#define MMAP_HEAP
+#define IEEE_DOUBLE
+#define LITTLE_ENDIAN_IEEE_DOUBLE
+#define LDEXP
+#define ARCHYPERBOLIC
+#define GETPAGESIZE() getpagesize()
+typedef char *memcpy_t;
+struct timespec;
+#define MAKE_NAN(x) { x = 0.0; x = x / x; }
+#define GETWD(x) getcwd((x),PATH_MAX)
+typedef int tputsputcchar;
+#define LOCKF
+#define DIRMARKERP(c) ((c) == '/')
+#ifndef DISABLE_X11
+#define LIBX11 "libX11.so"
+#endif
+#define SECATIME(sb) (sb).st_atimespec.tv_sec
+#define SECCTIME(sb) (sb).st_ctimespec.tv_sec
+#define SECMTIME(sb) (sb).st_mtimespec.tv_sec
+#define NSECATIME(sb) (sb).st_atimespec.tv_nsec
+#define NSECCTIME(sb) (sb).st_ctimespec.tv_nsec
+#define NSECMTIME(sb) (sb).st_mtimespec.tv_nsec
+#define ICONV_INBUF_TYPE char **
+#define UNUSED __attribute__((__unused__))
+#define USE_OSSP_UUID
+#endif
+
+#if (machine_type == machine_type_i3osx || machine_type == machine_type_ti3osx || machine_type == machine_type_a6osx || machine_type == machine_type_ta6osx)
+#if (machine_type == machine_type_ti3osx || machine_type == machine_type_ta6osx)
+#define PTHREADS
+#endif
+#if (machine_type == machine_type_a6osx || machine_type == machine_type_ta6osx)
+#ifndef NO_ROSETTA_CHECK
+#define CHECK_FOR_ROSETTA
+extern int is_rosetta;
+#endif
+#endif
+#define MACOSX
+#define NOBLOCK O_NONBLOCK
+#define LOAD_SHARED_OBJECT
+#define USE_MMAP
+#define MMAP_HEAP
+#define IEEE_DOUBLE
+#define LITTLE_ENDIAN_IEEE_DOUBLE
+#define LDEXP
+#define ARCHYPERBOLIC
+#define GETPAGESIZE() getpagesize()
+typedef char *memcpy_t;
+#define MAKE_NAN(x) { x = 0.0; x = x / x; }
+#define GETWD(x) getcwd((x),PATH_MAX)
+typedef int tputsputcchar;
+#define LOCKF
+#define DIRMARKERP(c) ((c) == '/')
+#ifndef DISABLE_X11
+#define LIBX11 "/usr/X11R6/lib/libX11.dylib"
+#endif
+#define _DARWIN_USE_64_BIT_INODE
+#define SECATIME(sb) (sb).st_atimespec.tv_sec
+#define SECCTIME(sb) (sb).st_ctimespec.tv_sec
+#define SECMTIME(sb) (sb).st_mtimespec.tv_sec
+#define NSECATIME(sb) (sb).st_atimespec.tv_nsec
+#define NSECCTIME(sb) (sb).st_ctimespec.tv_nsec
+#define NSECMTIME(sb) (sb).st_mtimespec.tv_nsec
+#define ICONV_INBUF_TYPE char **
+#define UNUSED __attribute__((__unused__))
+#endif
+
+#if (machine_type == machine_type_i3qnx || machine_type == machine_type_ti3qnx)
+#if (machine_type == machine_type_ti3qnx)
+#define PTHREADS
+#endif
+#define NOBLOCK O_NONBLOCK
+#define LOAD_SHARED_OBJECT
+#define USE_MMAP
+#define MMAP_HEAP
+#define IEEE_DOUBLE
+#define LITTLE_ENDIAN_IEEE_DOUBLE
+#define LDEXP
+#define ARCHYPERBOLIC
+#define GETPAGESIZE() getpagesize()
+typedef char *memcpy_t;
+#define MAKE_NAN(x) { x = 0.0; x = x / x; }
+#define GETWD(x) getcwd((x),PATH_MAX)
+typedef int tputsputcchar;
+#define LOCKF
+#define DIRMARKERP(c) ((c) == '/')
+#define LSEEK lseek64
+#define OFF_T off64_t
+#define _LARGEFILE64_SOURCE
+#define SECATIME(sb) (sb).st_atime
+#define SECCTIME(sb) (sb).st_ctime
+#define SECMTIME(sb) (sb).st_mtime
+#define NSECATIME(sb) 0
+#define NSECCTIME(sb) 0
+#define NSECMTIME(sb) 0
+#define ICONV_INBUF_TYPE char **
+#define NOFILE 256
+#define UNUSED
+#endif
+
+#if (machine_type == machine_type_i3s2 || machine_type == machine_type_ti3s2 || machine_type == machine_type_a6s2 || machine_type == machine_type_ta6s2)
+#if (machine_type == machine_type_ti3s2 || machine_type == machine_type_ta6s2)
+#define PTHREADS
+#endif
+#define NOBLOCK O_NONBLOCK
+#define LOAD_SHARED_OBJECT
+#define USE_MMAP
+#define MMAP_HEAP
+#define IEEE_DOUBLE
+#define LITTLE_ENDIAN_IEEE_DOUBLE
+#define LDEXP
+#define ARCHYPERBOLIC
+#define LOG1P
+#define DEFINE_MATHERR
+#define GETPAGESIZE() getpagesize()
+typedef char *memcpy_t;
+#define MAKE_NAN(x) { x = 0.0; x = x / x; }
+#define _setjmp setjmp
+#define _longjmp longjmp
+typedef char tputsputcchar;
+#define LOCKF
+#define DIRMARKERP(c) ((c) == '/')
+#ifndef DISABLE_X11
+#define LIBX11 "libX11.so"
+#endif
+#define SECATIME(sb) (sb).st_atim.tv_sec
+#define SECCTIME(sb) (sb).st_ctim.tv_sec
+#define SECMTIME(sb) (sb).st_mtim.tv_sec
+#define NSECATIME(sb) (sb).st_atim.tv_nsec
+#define NSECCTIME(sb) (sb).st_ctim.tv_nsec
+#define NSECMTIME(sb) (sb).st_mtim.tv_nsec
+#define ICONV_INBUF_TYPE const char **
+#define UNUSED __attribute__((__unused__))
+#endif
+
+/* defaults */
+
+#ifndef CHDIR
+# define CHDIR chdir
+#endif
+#ifndef CHMOD
+# define CHMOD chmod
+#endif
+#ifndef CLOSE
+# define CLOSE close
+#endif
+#ifndef DUP
+# define DUP dup
+#endif
+#ifndef FILENO
+# define FILENO fileno
+#endif
+#ifndef FSTAT
+# define FSTAT fstat
+#endif
+#ifndef GETPID
+# define GETPID getpid
+#endif
+#ifndef HYPOT
+# define HYPOT hypot
+#endif
+#ifndef OFF_T
+# define OFF_T off_t
+#endif
+#ifndef LSEEK
+# define LSEEK lseek
+#endif
+#ifndef LSTAT
+# define LSTAT lstat
+#endif
+#ifndef OPEN
+# define OPEN open
+#endif
+#ifndef READ
+# define READ read
+#endif
+#ifndef RENAME
+# define RENAME rename
+#endif
+#ifndef RMDIR
+# define RMDIR rmdir
+#endif
+#ifndef STAT
+# define STAT stat
+#endif
+#ifndef STATBUF
+# define STATBUF stat
+#endif
+#ifndef SYSTEM
+# define SYSTEM system
+#endif
+#ifndef UNLINK
+# define UNLINK unlink
+#endif
+#ifndef WRITE
+# define WRITE write
+#endif