chez-openbsd/c/prim5.c

/* prim5.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 "sort.h"

#include <sys/types.h>
#include <sys/stat.h>
#include <limits.h>
#include <ctype.h>
#include <math.h>

/* locally defined functions */
static INT s_errno(void);
static iptr s_addr_in_heap(uptr x);
static iptr s_ptr_in_heap(ptr x);
static ptr s_generation(ptr x);
static iptr s_fxmul(iptr x, iptr y);
static iptr s_fxdiv(iptr x, iptr y);
static ptr s_trunc_rem(ptr x, ptr y);
static ptr s_fltofx(ptr x);
static ptr s_weak_pairp(ptr p);
static ptr s_ephemeron_cons(ptr car, ptr cdr);
static ptr s_ephemeron_pairp(ptr p);
static ptr s_oblist(void);
static ptr s_bigoddp(ptr n);
static ptr s_float(ptr x);
static ptr s_decode_float(ptr x);
#ifdef segment_t2_bits
static void s_show_info(FILE *out);
#endif
static void s_show_chunks(FILE *out, ptr sorted_chunks);
static ptr sort_chunks(ptr ls, uptr n);
static ptr merge_chunks(ptr ls1, ptr ls2);
static ptr sorted_chunk_list(void);
static void s_showalloc(IBOOL show_dump, const char *outfn);
static ptr s_system(const char *s);
static ptr s_process(char *s, IBOOL stderrp);
static I32 s_chdir(const char *inpath);
static char *s_getwd(void);
static ptr s_set_code_byte(ptr p, ptr n, ptr x);
static ptr s_set_code_word(ptr p, ptr n, ptr x);
static ptr s_set_code_long(ptr p, ptr n, ptr x);
static void s_set_code_long2(ptr p, ptr n, ptr h, ptr l);
static ptr s_set_code_quad(ptr p, ptr n, ptr x);
static ptr s_set_reloc(ptr p, ptr n, ptr e);
static ptr s_flush_instruction_cache(void);
static ptr s_make_code(iptr flags, iptr free, ptr name, ptr arity_mark, iptr n, ptr info, ptr pinfos);
static ptr s_make_reloc_table(ptr codeobj, ptr n);
static ptr s_make_closure(ptr offset, ptr codeobj);
static ptr s_fxrandom(ptr n);
static ptr s_flrandom(ptr x);
static U32 s_random_seed(void);
static void s_set_random_seed(U32 x);
static ptr s_intern(ptr x);
static ptr s_intern2(ptr x, ptr n);
static ptr s_strings_to_gensym(ptr pname_str, ptr uname_str);
static ptr s_intern3(ptr x, ptr n, ptr m);
static ptr s_delete_file(const char *inpath);
static ptr s_delete_directory(const char *inpath);
static ptr s_rename_file(const char *inpath1, const char *inpath2);
static ptr s_mkdir(const char *inpath, INT mode);
static ptr s_chmod(const char *inpath, INT mode);
static ptr s_getmod(const char *inpath, IBOOL followp);
static ptr s_path_atime(const char *inpath, IBOOL followp);
static ptr s_path_ctime(const char *inpath, IBOOL followp);
static ptr s_path_mtime(const char *inpath, IBOOL followp);
static ptr s_fd_atime(INT fd);
static ptr s_fd_ctime(INT fd);
static ptr s_fd_mtime(INT fd);
static IBOOL s_fd_regularp(INT fd);
static void s_nanosleep(ptr sec, ptr nsec);
static ptr s_set_collect_trip_bytes(ptr n);
static void c_exit(I32 status);
static ptr s_get_reloc(ptr co);
#ifdef PTHREADS
static s_thread_rv_t s_backdoor_thread_start(void *p);
static iptr s_backdoor_thread(ptr p);
static ptr s_threads(void);
static void s_mutex_acquire(scheme_mutex_t *m);
static ptr s_mutex_acquire_noblock(scheme_mutex_t *m);
static void s_condition_broadcast(s_thread_cond_t *c);
static void s_condition_signal(s_thread_cond_t *c);
#endif
static void s_byte_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt);
static void s_ptr_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt);
static ptr s_tlv(ptr x);
static void s_stlv(ptr x, ptr v);
static void s_test_schlib(void);
static void s_breakhere(ptr x);
static IBOOL s_interactivep(void);
static IBOOL s_same_devicep(INT fd1, INT fd2);
static uptr s_malloc(iptr n);
static void s_free(uptr n);
#ifdef FEATURE_ICONV
static ptr s_iconv_open(const char *tocode, const char *fromcode);
static void s_iconv_close(uptr cd);
static ptr s_iconv_from_string(uptr cd, ptr in, uptr i, uptr iend, ptr out, uptr o, uptr oend);
static ptr s_iconv_to_string(uptr cd, ptr in, uptr i, uptr iend, ptr out, uptr o, uptr oend);
#endif
#ifdef WIN32
static ptr s_multibytetowidechar(unsigned cp, ptr inbv);
static ptr s_widechartomultibyte(unsigned cp, ptr inbv);
#endif
static ptr s_profile_counters(void);
static ptr s_profile_release_counters(void);

#define require(test,who,msg,arg) if (!(test)) S_error1(who, msg, arg)

ptr S_strerror(INT errnum) {
  ptr p; char *msg;

  tc_mutex_acquire()
#ifdef WIN32
  msg = Swide_to_utf8(_wcserror(errnum));
  if (msg == NULL)
    p = Sfalse;
  else {
    p = Sstring_utf8(msg, -1);
    free(msg);
  }
#else
  p = (msg = strerror(errnum)) == NULL ? Sfalse : Sstring_utf8(msg, -1);
#endif
  tc_mutex_release()
  return p;
}

static INT s_errno(void) {
  return errno;
}

static iptr s_addr_in_heap(uptr x) {
  return MaybeSegInfo(addr_get_segment(x)) != NULL;
}

static iptr s_ptr_in_heap(ptr x) {
  return MaybeSegInfo(ptr_get_segment(x)) != NULL;
}

static ptr s_generation(ptr x) {
  seginfo *si = MaybeSegInfo(ptr_get_segment(x));
  return si == NULL ? Sfalse : FIX(si->generation);
}

static iptr s_fxmul(iptr x, iptr y) {
    return x * y;
}

static iptr s_fxdiv(iptr x, iptr y) {
    return x / y;
}

static ptr s_trunc_rem(ptr x, ptr y) {
  ptr q, r;
  S_trunc_rem(get_thread_context(), x, y, &q, &r);
  return Scons(q, r);
}

static ptr s_fltofx(ptr x) {
    return FIX((iptr)FLODAT(x));
}

static ptr s_weak_pairp(ptr p) {
  seginfo *si;
  return Spairp(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->space & ~space_locked) == space_weakpair ? Strue : Sfalse;
}

static ptr s_ephemeron_cons(ptr car, ptr cdr) {
  ptr p;

  tc_mutex_acquire()
  p = S_cons_in(space_ephemeron, 0, car, cdr);
  tc_mutex_release()
  return p;
}

static ptr s_ephemeron_pairp(ptr p) {
  seginfo *si;
  return Spairp(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && (si->space & ~space_locked) == space_ephemeron ? Strue : Sfalse;
}

static ptr s_oblist(void) {
  ptr ls = Snil;
  iptr idx = S_G.oblist_length;
  bucket *b;

  while (idx-- != 0) {
    for (b = S_G.oblist[idx]; b != NULL; b = b->next) {
      ls = Scons(b->sym, ls);
    }
  }

  return ls;
}

static ptr s_bigoddp(ptr n) {
    return Sboolean(BIGIT(n, BIGLEN(n) - 1) & 1); /* last bigit */;
}

static ptr s_float(ptr x) {
    return Sflonum(S_floatify(x));
}

static ptr s_decode_float(ptr x) {
    require(Sflonump(x),"decode-float","~s is not a float",x);
    return S_decode_float(FLODAT(x));
}

#define FMTBUFSIZE 120
#define CHUNKADDRLT(x, y) (((chunkinfo *)(Scar(x)))->addr < ((chunkinfo *)(Scar(y)))->addr)
mkmergesort(sort_chunks, merge_chunks, ptr, Snil, CHUNKADDRLT, INITCDR)

static ptr sorted_chunk_list(void) {
  chunkinfo *chunk; INT i, n = 0; ptr ls = Snil;

  for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) {
    for (chunk = (i == -1) ? S_chunks_full : S_chunks[i]; chunk != NULL; chunk = chunk->next) {
      ls = Scons(chunk, ls);
      n += 1;
    }
  }

  return sort_chunks(ls, n);
}

#ifdef segment_t2_bits
static void s_show_info(FILE *out) {
  void *max_addr = 0;
  INT addrwidth;
  const char *addrtitle = "address";
  char fmtbuf[FMTBUFSIZE];
  uptr i2;
#ifdef segment_t3_bits
  INT byteswidth;
  uptr i3;
  for (i3 = 0; i3 < SEGMENT_T3_SIZE; i3 += 1) {
    t2table *t2t = S_segment_info[i3];
    if (t2t != NULL) {
      if ((void *)t2t > max_addr) max_addr = (void *)t2t;
      for (i2 = 0; i2 < SEGMENT_T2_SIZE; i2 += 1) {
        t1table *t1t = t2t->t2[i2];
        if (t1t != NULL) {
          if ((void *)t1t > max_addr) max_addr = (void *)t1t;
        }
      }
    }
  }
  addrwidth = snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)max_addr);
  if (addrwidth < (INT)strlen(addrtitle)) addrwidth = (INT)strlen(addrtitle);
  byteswidth = snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)(sizeof(t1table) > sizeof(t2table) ? sizeof(t1table) : sizeof(t2table)));
  snprintf(fmtbuf, FMTBUFSIZE, "%%s  %%-%ds  %%-%ds\n\n", addrwidth, byteswidth);
  fprintf(out, fmtbuf, "level", addrtitle, "bytes");
  snprintf(fmtbuf, FMTBUFSIZE, "%%-5d  %%#0%dtx  %%#0%dtx\n", addrwidth, byteswidth);
  for (i3 = 0; i3 < SEGMENT_T3_SIZE; i3 += 1) {
    t2table *t2t = S_segment_info[i3];
    if (t2t != NULL) {
      fprintf(out, fmtbuf, 2, t2t, sizeof(t2table));
      for (i2 = 0; i2 < SEGMENT_T2_SIZE; i2 += 1) {
        t1table *t1t = t2t->t2[i2];
        if (t1t != NULL) {
          fprintf(out, fmtbuf, 1, (ptrdiff_t)t1t, (ptrdiff_t)sizeof(t1table));
        }
      }
    }
  }
#else
  for (i2 = 0; i2 < SEGMENT_T2_SIZE; i2 += 1) {
    t1table *t1t = S_segment_info[i2];
    if (t1t != NULL) {
      if ((void *)t1t > max_addr) max_addr = (void *)t1t;
    }
  }
  addrwidth = 1 + snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)max_addr);
  if (addrwidth < (INT)strlen(addrtitle) + 1) addrwidth = (INT)strlen(addrtitle) + 1;
  snprintf(fmtbuf, FMTBUFSIZE, "%%s %%-%ds %%s\n\n", addrwidth);
  fprintf(out, fmtbuf, "level", addrtitle, "bytes");
  snprintf(fmtbuf, FMTBUFSIZE, "%%-5d %%#0%dtx %%#tx\n", (ptrdiff_t)addrwidth);
  for (i2 = 0; i2 < SEGMENT_T2_SIZE; i2 += 1) {
    t1table *t1t = S_segment_info[i2];
    if (t1t != NULL) {
      fprintf(out, fmtbuf, 1, (ptrdiff_t)t1t, (ptrdiff_t)sizeof(t1table));
    }
  }
#endif
}
#endif

static void s_show_chunks(FILE *out, ptr sorted_chunks) {
  char fmtbuf[FMTBUFSIZE];
  chunkinfo *chunk;
  void *max_addr = 0;
  void *max_header_addr = 0;
  iptr max_segs = 0;
  INT addrwidth, byteswidth, headeraddrwidth, headerbyteswidth, segswidth, headerwidth;
  const char *addrtitle = "address", *bytestitle = "bytes", *headertitle = "(+ header)";
  ptr ls;

  for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) {
    chunk = Scar(ls);
    max_addr = chunk->addr;
    if (chunk->segs > max_segs) max_segs = chunk->segs;
    if ((void *)chunk > max_header_addr) max_header_addr = (void *)chunk;
  }

  addrwidth = (INT)snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)max_addr);
  if (addrwidth < (INT)strlen(addrtitle)) addrwidth = (INT)strlen(addrtitle);
  byteswidth = (INT)snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)(max_segs * bytes_per_segment));
  if (byteswidth < (INT)strlen(bytestitle)) byteswidth = (INT)strlen(bytestitle);
  headerbyteswidth = (INT)snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)(sizeof(chunkinfo) + sizeof(seginfo) * max_segs));
  headeraddrwidth = (INT)snprintf(fmtbuf, FMTBUFSIZE, "%#tx", (ptrdiff_t)max_header_addr);
  segswidth = (INT)snprintf(fmtbuf, FMTBUFSIZE, "%td", (ptrdiff_t)max_segs);
  headerwidth = headerbyteswidth + headeraddrwidth + 13;

  snprintf(fmtbuf, FMTBUFSIZE, "%%-%ds %%-%ds %%-%ds %%s\n\n", addrwidth, byteswidth, headerwidth);
  fprintf(out, fmtbuf, addrtitle, bytestitle, headertitle, "segments used");
  snprintf(fmtbuf, FMTBUFSIZE, "%%#0%dtx %%#0%dtx (+ %%#0%dtx bytes @ %%#0%dtx) %%%dtd of %%%dtd\n",
      addrwidth, byteswidth, headerbyteswidth, headeraddrwidth, segswidth, segswidth);
  for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) {
    chunk = Scar(ls);
    fprintf(out, fmtbuf, (ptrdiff_t)chunk->addr, (ptrdiff_t)chunk->bytes,
        (ptrdiff_t)(sizeof(chunkinfo) + sizeof(seginfo) * chunk->segs),
        (ptrdiff_t)chunk, (ptrdiff_t)chunk->nused_segs, (ptrdiff_t)chunk->segs);
  }
}

#define space_bogus (max_space + 1)
#define space_total (space_bogus + 1)
#define generation_total (static_generation + 1)
#define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1)
static void s_showalloc(IBOOL show_dump, const char *outfn) {
  FILE *out;
  iptr count[generation_total+1][space_total+1];
  uptr bytes[generation_total+1][space_total+1];
  int i, column_size[generation_total+1];
  char fmtbuf[FMTBUFSIZE];
  static char *spacename[space_total+1] = { alloc_space_names, "bogus", "total" };
  static char spacechar[space_total+1] = { alloc_space_chars, '?', 't' };
  chunkinfo *chunk; seginfo *si; ISPC s; IGEN g;
  ptr sorted_chunks;

  tc_mutex_acquire()

  if (outfn == NULL) {
    out = stderr;
  } else {
#ifdef WIN32
    wchar_t *outfnw = Sutf8_to_wide(outfn);
    out = _wfopen(outfnw, L"w");
    free(outfnw);
#else
    out = fopen(outfn, "w");
#endif
    if (out == NULL) {
      ptr msg = S_strerror(errno);
      if (msg != Sfalse) {
        tc_mutex_release()
        S_error2("fopen", "open of ~s failed: ~a", Sstring_utf8(outfn, -1), msg);
      } else {
        tc_mutex_release()
        S_error1("fopen", "open of ~s failed", Sstring_utf8(outfn, -1));
      }
    }
  }
  for (g = 0; g <= generation_total; INCRGEN(g))
    for (s = 0; s <= space_total; s++)
      count[g][s] = bytes[g][s] = 0;

  for (g = 0; g <= static_generation; INCRGEN(g)) {
    for (s = 0; s <= max_real_space; s++) {
      /* add in bytes previously recorded */
      bytes[g][s] += S_G.bytes_of_space[g][s];
      /* add in bytes in active segments */
      if (S_G.next_loc[g][s] != FIX(0))
        bytes[g][s] += (char *)S_G.next_loc[g][s] - (char *)S_G.base_loc[g][s];
    }
  }

  for (g = 0; g <= static_generation; INCRGEN(g)) {
    for (s = 0; s <= max_real_space; s++) {
      for (si = S_G.occupied_segments[g][s]; si != NULL; si = si->next) {
        count[g][s] += 1;
      }
    }
  }

  for (g = 0; g < generation_total; INCRGEN(g)) {
    for (s = 0; s < space_total; s++) {
      count[g][space_total] += count[g][s];
      count[generation_total][s] += count[g][s];
      count[generation_total][space_total] += count[g][s];
      bytes[g][space_total] += bytes[g][s];
      bytes[generation_total][s] += bytes[g][s];
      bytes[generation_total][space_total] += bytes[g][s];
    }
  }

  for (g = 0; g <= generation_total; INCRGEN(g)) {
    if (count[g][space_total] != 0) {
      int n = 1 + snprintf(fmtbuf, FMTBUFSIZE, "%td", (ptrdiff_t)count[g][space_total]);
      column_size[g] = n < 8 ? 8 : n;
    }
  }

  fprintf(out, "Segments per space & generation:\n\n");
  fprintf(out, "%8s", "");
  for (g = 0; g <= generation_total; INCRGEN(g)) {
    if (count[g][space_total] != 0) {
      if (g == generation_total) {
        /* coverity[uninit_use] */
        snprintf(fmtbuf, FMTBUFSIZE, "%%%ds", column_size[g]);
        fprintf(out, fmtbuf, "total");
      } else if (g == static_generation) {
        /* coverity[uninit_use] */
        snprintf(fmtbuf, FMTBUFSIZE, "%%%ds", column_size[g]);
        fprintf(out, fmtbuf, "static");
      } else {
        /* coverity[uninit_use] */
        snprintf(fmtbuf, FMTBUFSIZE, "%%%dd", column_size[g]);
        fprintf(out, fmtbuf, g);
      }
    }
  }
  fprintf(out, "\n");
  for (s = 0; s <= space_total; s++) {
    if (s != space_empty) {
      if (count[generation_total][s] != 0) {
        fprintf(out, "%7s:", spacename[s]);
        for (g = 0; g <= generation_total; INCRGEN(g)) {
          if (count[g][space_total] != 0) {
            /* coverity[uninit_use] */
            snprintf(fmtbuf, FMTBUFSIZE, "%%%dtd", column_size[g]);
            fprintf(out, fmtbuf, (ptrdiff_t)(count[g][s]));
          }
        }
        fprintf(out, "\n");
        fprintf(out, "%8s", "");
        for (g = 0; g <= generation_total; INCRGEN(g)) {
          if (count[g][space_total] != 0) {
            if (count[g][s] != 0 && s <= max_real_space) {
              /* coverity[uninit_use] */
              snprintf(fmtbuf, FMTBUFSIZE, "%%%dd%%%%", column_size[g] - 1);
              fprintf(out, fmtbuf,
                  (int)(((double)bytes[g][s] /
                      ((double)count[g][s] * bytes_per_segment)) * 100.0));
            } else {
              /* coverity[uninit_use] */
              snprintf(fmtbuf, FMTBUFSIZE, "%%%ds", column_size[g]);
              fprintf(out, fmtbuf, "");
            }
          }
        }
        fprintf(out, "\n");
      }
    }
  }

  fprintf(out, "segment size = %#tx bytes.  percentages show the portion actually occupied.\n", (ptrdiff_t)bytes_per_segment);
  fprintf(out, "%td segments are presently reserved for future allocation or collection.\n", (ptrdiff_t)S_G.number_of_empty_segments);

  fprintf(out, "\nMemory chunks obtained and not returned to the O/S:\n\n");
  sorted_chunks = sorted_chunk_list();
  s_show_chunks(out, sorted_chunks);

#ifdef segment_t2_bits
  fprintf(out, "\nDynamic memory occupied by segment info table:\n\n");
  s_show_info(out);
#endif

  fprintf(out, "\nAdditional memory might be used by C libraries and programs in the\nsame address space.\n");

  if (show_dump) {
    iptr max_seg = 0;
    int segwidth, segsperline;
    iptr next_base = 0;
    int segsprinted = 0;
    char spaceline[100], genline[100];
    ptr ls;

    for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) {
      iptr last_seg;
      chunk = Scar(ls);
      last_seg = chunk->base + chunk->segs;
      if (last_seg > max_seg) max_seg = last_seg;
    }

    segwidth = snprintf(fmtbuf, FMTBUFSIZE, "%#tx ", (ptrdiff_t)max_seg);
    segsperline = (99 - segwidth) & ~0xf;
    
    snprintf(fmtbuf, FMTBUFSIZE, "  %%-%ds", segwidth);
    snprintf(genline, 100, fmtbuf, "");

    fprintf(out, "\nMap of occupied segments:\n");
    for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) {
      seginfo *si; ISPC real_s;

      chunk = Scar(ls);

      if (chunk->base != next_base && segsprinted != 0) {
        for (;;) {
          if (segsprinted == segsperline) {
            fprintf(out, "\n%s", spaceline);
            fprintf(out, "\n%s", genline);
            break;
          }
          if (next_base == chunk->base) break;
          spaceline[segwidth+segsprinted] = ' ';
          genline[segwidth+segsprinted] = ' ';
          segsprinted += 1;
          next_base += 1;
        }
      }

      if (chunk->base > next_base && next_base != 0) {
        fprintf(out, "\n-------- skipping %td segments --------", (ptrdiff_t)(chunk->base - next_base));
      }

      for (i = 0; i < chunk->segs; i += 1) {
        if (segsprinted >= segsperline) segsprinted = 0;
        
        if (segsprinted == 0) {
          if (i != 0) {
            fprintf(out, "\n%s", spaceline);
            fprintf(out, "\n%s", genline);
          }
          snprintf(fmtbuf, FMTBUFSIZE, "%%#0%dtx ", segwidth - 1);
          snprintf(spaceline, 100, fmtbuf, (ptrdiff_t)(chunk->base + i));
          segsprinted = 0;
        }

        si = &chunk->sis[i];
        real_s = si->space;
        s = real_s & ~(space_locked | space_old);
        if (s < 0 || s > max_space) s = space_bogus;
        spaceline[segwidth+segsprinted] =
          real_s & (space_locked | space_old) ? toupper(spacechar[s]) : spacechar[s];

        g = si->generation;
        genline[segwidth+segsprinted] =
          (s == space_empty) ? '.' :
          (g < 10) ? '0' + g :
          (g < 36) ? 'A' + g - 10 :
          (g == static_generation) ? '*' : '+';
        segsprinted += 1;
      }
      next_base = chunk->base + chunk->segs;  
    }

    if (segsprinted != 0) {
      spaceline[segwidth+segsprinted] = 0;
      genline[segwidth+segsprinted] = 0;
      fprintf(out, "\n%s", spaceline);
      fprintf(out, "\n%s", genline);
    }

    fprintf(out, "\n\nSpaces:");
    for (s = 0; s < space_total; s += 1)
      fprintf(out, "%s%c = %s", s % 5 == 0 ? "\n  " : "\t",
          spacechar[s], spacename[s]);
    fprintf(out, "\n\nGenerations:\n  0-9: 0<=g<=9; A-Z: 10<=g<=35; +: g>=36; *: g=static; .: empty\n\n");
  }

  if (outfn == NULL) {
    fflush(out);
  } else {
    fclose(out);
  }

  tc_mutex_release()
}

#include <signal.h>
#ifdef WIN32
#include <io.h>
#include <process.h>
#include <fcntl.h>
#include <direct.h>
#include <malloc.h>
#else /* WIN32 */
#include <sys/param.h>
#include <sys/wait.h>
#endif /* WIN32 */

static ptr s_system(const char *s) {
  INT status;
#ifdef PTHREADS
  ptr tc = get_thread_context();
#endif

#ifdef PTHREADS
  if (DISABLECOUNT(tc) == FIX(0)) deactivate_thread(tc);
#endif
  status = SYSTEM(s);
#ifdef PTHREADS
  if (DISABLECOUNT(tc) == FIX(0)) reactivate_thread(tc);
#endif

  if ((status == -1) && (errno != 0)) {
    ptr msg = S_strerror(errno);

    if (msg != Sfalse)
      S_error1("system", "~a", msg);
    else
      S_error("system", "subprocess execution failed");
  }

#ifdef WIN32
  return Sinteger(status);
#else
  if WIFEXITED(status) return Sinteger(WEXITSTATUS(status));
  if WIFSIGNALED(status) return Sinteger(-WTERMSIG(status));
  S_error("system", "cannot determine subprocess exit status");
  return 0 /* not reached */;
#endif /* WIN32 */
}

static ptr s_process(char *s, IBOOL stderrp) {
    INT ifd = -1, ofd = -1, efd = -1, child = -1;

#ifdef WIN32
    HANDLE hToRead, hToWrite, hFromRead, hFromWrite, hFromReadErr, hFromWriteErr, hProcess;
    STARTUPINFOW si = {0};
    PROCESS_INFORMATION pi;
    char *comspec;
    char *buffer;
    wchar_t* bufferw;

    /* Create non-inheritable pipes, important to eliminate zombee children
     * when the parent sides are closed. */
    if (!CreatePipe(&hToRead, &hToWrite, NULL, 0))
        S_error("process", "cannot open pipes");
    if (!CreatePipe(&hFromRead, &hFromWrite, NULL, 0)) {
        CloseHandle(hToRead);
        CloseHandle(hToWrite);
        S_error("process", "cannot open pipes");
    }
    if (stderrp && !CreatePipe(&hFromReadErr, &hFromWriteErr, NULL, 0)) {
        CloseHandle(hToRead);
        CloseHandle(hToWrite);
        CloseHandle(hFromRead);
        CloseHandle(hFromWrite);
        S_error("process", "cannot open pipes");
    }

    si.cb = sizeof(STARTUPINFO);
    si.dwFlags = STARTF_USESTDHANDLES;
    hProcess = GetCurrentProcess();

    /* Duplicate the ToRead handle so that the child can inherit it. */
    if (!DuplicateHandle(hProcess, hToRead, hProcess, &si.hStdInput,
                         GENERIC_READ, TRUE, 0)) {
        CloseHandle(hToRead);
        CloseHandle(hToWrite);
        CloseHandle(hFromRead);
        CloseHandle(hFromWrite);
        if (stderrp) {
          CloseHandle(hFromReadErr);
          CloseHandle(hFromWriteErr);
        }
        S_error("process", "cannot open pipes");
    }
    CloseHandle(hToRead);

    /* Duplicate the FromWrite handle so that the child can inherit it. */
    if (!DuplicateHandle(hProcess, hFromWrite, hProcess, &si.hStdOutput,
                         GENERIC_WRITE, TRUE, 0)) {
        CloseHandle(si.hStdInput);
        CloseHandle(hToWrite);
        CloseHandle(hFromRead);
        CloseHandle(hFromWrite);
        if (stderrp) {
          CloseHandle(hFromReadErr);
          CloseHandle(hFromWriteErr);
        }
        S_error("process", "cannot open pipes");
    }
    CloseHandle(hFromWrite);

    if (stderrp) {
      /* Duplicate the FromWrite handle so that the child can inherit it. */
      if (!DuplicateHandle(hProcess, hFromWriteErr, hProcess, &si.hStdError,
                           GENERIC_WRITE, TRUE, 0)) {
          CloseHandle(si.hStdInput);
          CloseHandle(hToWrite);
          CloseHandle(hFromRead);
          CloseHandle(hFromWrite);
          CloseHandle(hFromReadErr);
          CloseHandle(hFromWriteErr);
          S_error("process", "cannot open pipes");
      }
      CloseHandle(hFromWriteErr);
    } else {
      si.hStdError = si.hStdOutput;
    }

    if ((comspec = Sgetenv("COMSPEC"))) {
        size_t n = strlen(comspec) + strlen(s) + 7;
        buffer = (char *)_alloca(n);
        snprintf(buffer, n, "\"%s\" /c %s", comspec, s);
        free(comspec);
    } else
        buffer = s;
    bufferw = Sutf8_to_wide(buffer);
    if (!CreateProcessW(NULL, bufferw, NULL, NULL, TRUE, 0, NULL, NULL, &si, &pi)) {
        free(bufferw);
        CloseHandle(si.hStdInput);
        CloseHandle(hToWrite);
        CloseHandle(hFromRead);
        CloseHandle(si.hStdOutput);
        if (stderrp) {
          CloseHandle(hFromReadErr);
          CloseHandle(si.hStdError);
        }
        S_error("process", "cannot spawn subprocess");
    }
    free(bufferw);
    CloseHandle(si.hStdInput);
    CloseHandle(si.hStdOutput);
    if (stderrp) {
      CloseHandle(si.hStdError);
    }
    CloseHandle(pi.hProcess);
    CloseHandle(pi.hThread);

    ifd = _open_osfhandle((intptr_t)hFromRead, 0);
    ofd = _open_osfhandle((intptr_t)hToWrite, 0);
    if (stderrp) {
      efd = _open_osfhandle((intptr_t)hFromReadErr, 0);
    }
    child = pi.dwProcessId;

#else /* WIN32 */

    INT tofds[2], fromfds[2], errfds[2];
    struct sigaction act, oint_act;

    if (pipe(tofds)) S_error("process","cannot open pipes");
    if (pipe(fromfds)) {
        CLOSE(tofds[0]); CLOSE(tofds[1]);
        S_error("process","cannot open pipes");
    }
    if (stderrp) {
      if (pipe(errfds)) {
          CLOSE(tofds[0]); CLOSE(tofds[1]);
          CLOSE(fromfds[0]); CLOSE(fromfds[1]);
          S_error("process","cannot open pipes");
      }
    }

    sigemptyset(&act.sa_mask);
    act.sa_flags = 0;
    act.sa_handler = SIG_IGN;
    sigaction(SIGINT, &act, &oint_act);

    if ((child = fork()) == 0) {
      /* child does this: */
        CLOSE(0); if (dup(tofds[0]) != 0) _exit(1);
        CLOSE(1); if (dup(fromfds[1]) != 1) _exit(1);
        CLOSE(2); if (dup(stderrp ? errfds[1] : 1) != 2) _exit(1);
        {INT i; for (i = 3; i < NOFILE; i++) (void)CLOSE(i);}
        execl("/bin/sh", "/bin/sh", "-c", s, NULL);
        _exit(1) /* only if execl fails */;
        /*NOTREACHED*/
    } else {
      /* parent does this: */
        CLOSE(tofds[0]); CLOSE(fromfds[1]); if (stderrp) CLOSE(errfds[1]);
        if (child < 0) {
            CLOSE(tofds[1]); CLOSE(fromfds[0]); if (stderrp) CLOSE(errfds[0]);
            sigaction(SIGINT, &oint_act, (struct sigaction *)0);
            S_error("process", "cannot fork subprocess");
            /*NOTREACHED*/
        } else {
            ifd = fromfds[0];
            ofd = tofds[1];
            if (stderrp) efd = errfds[0];
            sigaction(SIGINT, &oint_act, (struct sigaction *)0);
            S_register_child_process(child);
        }
    }
#endif /* WIN32 */

    if (stderrp)
      return LIST4(FIX(ifd), FIX(efd), FIX(ofd), FIX(child));
    else
      return LIST3(FIX(ifd), FIX(ofd), FIX(child));
}

static I32 s_chdir(const char *inpath) {
    char *path;
    I32 status;

    path = S_malloc_pathname(inpath);
#ifdef EINTR
    while ((status = CHDIR(path)) != 0 && errno == EINTR) ;
#else /* EINTR */
    status = CHDIR(path);
#endif /* EINTR */
    free(path);
    return status;
}

#ifdef GETWD
static char *s_getwd() {
  return GETWD((char *)&BVIT(S_bytevector(PATH_MAX), 0));
}
#endif /* GETWD */

static ptr s_set_code_byte(ptr p, ptr n, ptr x) {
    I8 *a;

    a = (I8 *)((uptr)p + UNFIX(n));
    *a = (I8)UNFIX(x);
    return Svoid;
}

static ptr s_set_code_word(ptr p, ptr n, ptr x) {
    I16 *a;

    a = (I16 *)((uptr)p + UNFIX(n));
    *a = (I16)UNFIX(x);
    return Svoid;
}

static ptr s_set_code_long(ptr p, ptr n, ptr x) {
    I32 *a;

    a = (I32 *)((uptr)p + UNFIX(n));
    *a = (I32)(Sfixnump(x) ? UNFIX(x) : Sinteger_value(x));
    return Svoid;
}

static void s_set_code_long2(ptr p, ptr n, ptr h, ptr l) {
    I32 *a;

    a = (I32 *)((uptr)p + UNFIX(n));
    *a = (I32)((UNFIX(h) << 16) + UNFIX(l));
}

static ptr s_set_code_quad(ptr p, ptr n, ptr x) {
    I64 *a;

    a = (I64 *)((uptr)p + UNFIX(n));
    *a = Sfixnump(x) ? UNFIX(x) : S_int64_value("\\#set-code-quad!", x);
    return Svoid;
}

static ptr s_set_reloc(ptr p, ptr n, ptr e) {
    iptr *a;

    a = (iptr *)(&RELOCIT(CODERELOC(p), UNFIX(n)));
    *a = Sfixnump(e) ? UNFIX(e) : Sinteger_value(e);
    return e;
}

static ptr s_flush_instruction_cache(void) {
    tc_mutex_acquire()
    S_flush_instruction_cache(get_thread_context());
    tc_mutex_release()
    return Svoid;
}

static ptr s_make_code(flags, free, name, arity_mark, n, info, pinfos)
                       iptr flags, free, n; ptr name, arity_mark, info, pinfos; {
    ptr co;

    tc_mutex_acquire()
    co = S_code(get_thread_context(), type_code | (flags << code_flags_offset), n);
    tc_mutex_release()
    CODEFREE(co) = free;
    CODENAME(co) = name;
    CODEARITYMASK(co) = arity_mark;
    CODEINFO(co) = info;
    CODEPINFOS(co) = pinfos;
    if (pinfos != Snil) {
      S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters);
    }
    return co;
}

static ptr s_make_reloc_table(ptr codeobj, ptr n) {
    CODERELOC(codeobj) = S_relocation_table(UNFIX(n));
    RELOCCODE(CODERELOC(codeobj)) = codeobj;
    return Svoid;
}

static ptr s_make_closure(ptr offset, ptr codeobj) {

    return S_closure((ptr)((iptr)codeobj + UNFIX(offset)), 0);
}

/* the random formula is based on Knuth.  It returns a random fixnum
 * between 0 and n-1.
 */
static ptr s_fxrandom(ptr p) {
  ptr tc = get_thread_context();
  uptr t, n = UNFIX(p);

  t = (RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387) >> 16;
  t = t | ((RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387) & 0xffff0000);
  if (n <= 0xffffffff) /* trivially true if sizeof(ptr) <= sizeof(U32) */
    return FIX(t % n);
  else {
    t = (t << 16) | ((RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387) >> 16);
    t = (t << 16) | ((RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387) >> 16);
    return FIX(t % n);
  }
}

static ptr s_flrandom(ptr x) {
    ptr tc = get_thread_context();
    U32 t1, t2, t3, t4;

    t1 = RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387;
    t2 = RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387;
    t3 = RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387;
    t4 = RANDOMSEED(tc) = RANDOMSEED(tc) * 72931 + 90763387;
    return Sflonum(S_random_double(t1, t2, t3, t4, FLODAT(x)));
}

static U32 s_random_seed() {
    ptr tc = get_thread_context();
    return RANDOMSEED(tc);
}

static void s_set_random_seed(U32 x) {
    ptr tc = get_thread_context();
    RANDOMSEED(tc) = x;
}

static ptr s_intern(ptr x) {
  require(Sstringp(x),"string->symbol","~s is not a string",x);

  return S_intern_sc(&STRIT(x, 0), Sstring_length(x), x);
}

static ptr s_intern2(ptr x, ptr n) {
  return S_intern_sc(&STRIT(x, 0), UNFIX(n), Sfalse);
}

/* first n chars str are pretty name; remaining m-n are unique name */
static ptr s_intern3(ptr x, ptr n, ptr m) {
  iptr plen = UNFIX(n);
  return S_intern3(&STRIT(x, 0), plen, &STRIT(x, plen), UNFIX(m) - plen, Sfalse, Sfalse);
}

static ptr s_strings_to_gensym(ptr pname_str, ptr uname_str) {
  return S_intern3(&STRIT(pname_str, 0), Sstring_length(pname_str),
                   &STRIT(uname_str, 0), Sstring_length(uname_str),
                   pname_str, uname_str);
}

static ptr s_mkdir(const char *inpath, INT mode) {
  INT status; ptr res; char *path;

  path = S_malloc_pathname(inpath);
#ifdef WIN32
  status = S_windows_mkdir(path);
#else /* WIN32 */
  status = mkdir(path, mode);
#endif /* WIN32 */

  res = status == 0 ? Strue : S_strerror(errno);
  free(path);
  return res;
}

static ptr s_delete_file(const char *inpath) {
  ptr res; char *path;

  path = S_malloc_pathname(inpath);
  res = UNLINK(path) == 0 ? Strue : S_strerror(errno);
  free(path);
  return res;
}

static ptr s_delete_directory(const char *inpath) {
  ptr res; char *path;

  path = S_malloc_pathname(inpath);
  res = RMDIR(path) == 0 ? Strue : S_strerror(errno);
  free(path);
  return res;
}

static ptr s_rename_file(const char *inpath1, const char *inpath2) {
  ptr res; char *path1, *path2;

  path1 = S_malloc_pathname(inpath1);
  path2 = S_malloc_pathname(inpath2);
  res = RENAME(path1, path2) == 0 ? Strue : S_strerror(errno);
  free(path1);
  free(path2);
  return res;
}

static ptr s_chmod(const char *inpath, INT mode) {
  ptr res; INT status; char *path;

  path = S_malloc_pathname(inpath);
#ifdef WIN32
 /* pathetic approximation: (a) only handles user permissions, (b) doesn't
    handle execute permissions, (c) windows won't make file not readable */
  status = CHMOD(path,
                 (mode & 0400 ? S_IREAD : 0) |
                 (mode & 0200 ? S_IWRITE : 0));
#else /* WIN32 */
  status = CHMOD(path, mode);
#endif /* WIN32 */
  res = status == 0 ? Strue : S_strerror(errno);
  free(path);
  return res;
}

static ptr s_getmod(const char *inpath, IBOOL followp) {
  ptr res; char *path; struct STATBUF statbuf;

  path = S_malloc_pathname(inpath);

 /* according to msdn, user read/write bits are set according to the file's
    permission mode, and user execute bits are set according to the
    filename extension.  it says nothing about group and other execute bits. */

  if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) {
    res = S_strerror(errno);
  } else {
    res = FIX(statbuf.st_mode & 07777);
  }
  free(path);
  return res;
}

static ptr s_path_atime(const char *inpath, IBOOL followp) {
#ifdef WIN32
  ptr res;
  wchar_t *wpath;
  WIN32_FILE_ATTRIBUTE_DATA filedata;
  __int64 total, sec; int nsec;
  
  if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
    res = S_LastErrorString();
  } else if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) {
    DWORD err = GetLastError();
    res = err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ?
          Sstring("no such file or directory") :
          S_LastErrorString();
  } else {
    total = filedata.ftLastAccessTime.dwHighDateTime;
    total <<= 32;
    total |= filedata.ftLastAccessTime.dwLowDateTime;
    sec = total / 10000000 - 11644473600L;
    nsec = (total % 10000000) * 100;
    res = Scons(Sinteger64(sec), Sinteger32(nsec));
  }
  free(wpath);
  return res;
#else /* WIN32 */
  ptr res;
  char *path;
  struct STATBUF statbuf;

  path = S_malloc_pathname(inpath);
  if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) {
    res = S_strerror(errno);
  } else {
    res = Scons(Sinteger64(SECATIME(statbuf)), Sinteger32(NSECATIME(statbuf)));
  }
  free(path);
  return res;
#endif /* WIN32 */
}

static ptr s_path_ctime(const char *inpath, IBOOL followp) {
#ifdef WIN32
  ptr res;
  wchar_t *wpath;
  WIN32_FILE_ATTRIBUTE_DATA filedata;
  __int64 total, sec; int nsec;
  
  if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
    res = S_LastErrorString();
  } else if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) {
    DWORD err = GetLastError();
    res = err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ?
          Sstring("no such file or directory") :
          S_LastErrorString();
  } else {
    total = filedata.ftLastWriteTime.dwHighDateTime;
    total <<= 32;
    total |= filedata.ftLastWriteTime.dwLowDateTime;
    sec = total / 10000000 - 11644473600L;
    nsec = (total % 10000000) * 100;
    res = Scons(Sinteger64(sec), Sinteger32(nsec));
  }
  free(wpath);
  return res;
#else /* WIN32 */
  ptr res;
  char *path;
  struct STATBUF statbuf;

  path = S_malloc_pathname(inpath);
  if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) {
    res = S_strerror(errno);
  } else {
    res = Scons(Sinteger64(SECCTIME(statbuf)), Sinteger32(NSECCTIME(statbuf)));
  }
  free(path);
  return res;
#endif /* WIN32 */
}

static ptr s_path_mtime(const char *inpath, IBOOL followp) {
#ifdef WIN32
  ptr res;
  wchar_t *wpath;
  WIN32_FILE_ATTRIBUTE_DATA filedata;
  __int64 total, sec; int nsec;
  
  if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
    res = S_LastErrorString();
  } else if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) {
    DWORD err = GetLastError();
    res = err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ?
          Sstring("no such file or directory") :
          S_LastErrorString();
  } else {
    total = filedata.ftLastWriteTime.dwHighDateTime;
    total <<= 32;
    total |= filedata.ftLastWriteTime.dwLowDateTime;
    sec = total / 10000000 - 11644473600L;
    nsec = (total % 10000000) * 100;
    res = Scons(Sinteger64(sec), Sinteger32(nsec));
  }
  free(wpath);
  return res;
#else /* WIN32 */
  ptr res;
  char *path;
  struct STATBUF statbuf;

  path = S_malloc_pathname(inpath);
  if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) {
    res = S_strerror(errno);
  } else {
    res = Scons(Sinteger64(SECMTIME(statbuf)), Sinteger32(NSECMTIME(statbuf)));
  }
  free(path);
  return res;
#endif /* WIN32 */
}

static ptr s_fd_atime(INT fd) {
  struct STATBUF statbuf;

  if (FSTAT(fd, &statbuf) != 0) return S_strerror(errno);

  return Scons(Sinteger64(SECATIME(statbuf)), Sinteger32(NSECATIME(statbuf)));
}

static ptr s_fd_ctime(INT fd) {
  struct STATBUF statbuf;

  if (FSTAT(fd, &statbuf) != 0) return S_strerror(errno);

  return Scons(Sinteger64(SECCTIME(statbuf)), Sinteger32(NSECCTIME(statbuf)));
}

static ptr s_fd_mtime(INT fd) {
  struct STATBUF statbuf;

  if (FSTAT(fd, &statbuf) != 0) return S_strerror(errno);

  return Scons(Sinteger64(SECMTIME(statbuf)), Sinteger32(NSECMTIME(statbuf)));
}

static IBOOL s_fd_regularp(INT fd) {
  struct STATBUF statbuf;
  
  if (FSTAT(fd, &statbuf) != 0) return 0;

  return statbuf.st_mode & S_IFREG;
}

static void s_nanosleep(ptr xsec, ptr xnsec) {
  ptr tc = get_thread_context();
  U64 sec = Sunsigned64_value(xsec);
  U32 nsec = Sunsigned32_value(xnsec);
#ifdef PTHREADS
  if (DISABLECOUNT(tc) == 0) {
    deactivate_thread(tc)
  }
#endif /* PTHREADS */
 /* give up our lightweight thread "quanta" */
  if (DISABLECOUNT(tc) == 0) {
    TRAP(get_thread_context()) = (ptr)1;
  }
#ifdef WIN32
 /* round to nearest ms represented by sec and nsec */
  Sleep((DWORD)(sec * 1000 + (nsec + 500000) / 1000000));
#else /* WIN32 */
  struct timespec rqtp;
  rqtp.tv_sec = sec;
  rqtp.tv_nsec = nsec;
  nanosleep(&rqtp, NULL);
#endif /* WIN32 */
#ifdef PTHREADS
  if (DISABLECOUNT(tc) == 0) {
    reactivate_thread(tc)
  }
#endif /* PTHREADS */
}

static int s_getpid(void) {
  return GETPID();
}

static ptr s_set_collect_trip_bytes(ptr n) {
    S_G.collect_trip_bytes = Sunsigned_value(n);
    return Svoid;
}

static void c_exit(UNUSED I32 status) {
    S_abnormal_exit();
}

static double s_mod(double x, double y) { return fmod(x, y); }

static double s_exp(double x) { return exp(x); }

static double s_log(double x) { return log(x); }

#if (machine_type == machine_type_i3fb || machine_type == machine_type_ti3fb)
#include <ieeefp.h>
/* freebsd's pow delivers precise results for integer inputs, e.g.,
 * 10.0^21.0, only with * extended-precision (80-bit) floats */
static double s_pow(double x, double y) {
  fp_prec_t p;
  p = fpgetprec();
  if (p != FP_PE) {
    double ans;
    fpsetprec(FP_PE);
    ans = pow(x, y);
    fpsetprec(p);
    return ans;
  } else
    return pow(x, y);
}
#elif defined(MACOSX)
/* intel macosx delivers precise results for integer inputs, e.g.,
 * 10.0^21.0, only with long double version of pow */
static double s_pow(double x, double y) { return powl(x, y); }
#else /* i3fb/ti3fb */
static double s_pow(double x, double y) { return pow(x, y); }
#endif /* i3fb/ti3fb */

static double s_sqrt(double x) { return sqrt(x); }

static double s_sin(double x) { return sin(x); }

static double s_cos(double x) { return cos(x); }

static double s_tan(double x) { return tan(x); }

static double s_asin(double x) { return asin(x); }

static double s_acos(double x) { return acos(x); }

static double s_atan(double x) { return atan(x); }

static double s_atan2(double x, double y) { return atan2(x, y); }

static double s_sinh(double x) { return sinh(x); }

static double s_cosh(double x) { return cosh(x); }

static double s_tanh(double x) { return tanh(x); }

static double s_floor(double x) { return floor(x); }

static double s_ceil(double x) { return ceil(x); }

static double s_hypot(double x, double y) { return HYPOT(x, y); }

#ifdef ARCHYPERBOLIC
static double s_asinh(double x) { return asinh(x); }

static double s_acosh(double x){ return acosh(x); }

static double s_atanh(double x) { return atanh(x); }
#endif /* ARCHHYPERBOLIC */

#ifdef LOG1P
static double s_log1p(double x) { return log1p(x); }
#endif /* LOG1P */

static ptr s_getenv(char *name) {
#ifdef WIN32
  char *s = Sgetenv(name);
#else /* WIN32 */
  char *s = getenv(name);
#endif /* WIN32 */
  if (s == (char *)0)
    return Sfalse;
  else {
    ptr r = Sstring_utf8(s, -1);
#ifdef WIN32
    free(s);
#endif
    return r;
  }
}

static void s_putenv(char *name, char *value) {
#ifdef WIN32
  wchar_t* namew;
  wchar_t* valuew;
  BOOL rc;
  namew = Sutf8_to_wide(name);
  valuew = Sutf8_to_wide(value);
  rc = SetEnvironmentVariableW(namew, valuew);
  free(namew);
  free(valuew);
  if (rc == 0)
    S_error1("putenv", "environment extension failed: ~a", S_LastErrorString());
#else /* WIN32 */
  if (setenv(name, value, 1) != 0) {
    ptr msg = S_strerror(errno);

    if (msg != Sfalse)
      S_error1("putenv", "environment extension failed: ~a", msg);
    else
      S_error("putenv", "environment extension failed");
  }
#endif /* WIN32 */
}

#ifdef PTHREADS
/* backdoor thread is for testing thread creation by Sactivate_thread */
#define display(s) { const char *S = (s); if (WRITE(1, S, (unsigned int)strlen(S))) {} }
static s_thread_rv_t s_backdoor_thread_start(void *p) {
  display("backdoor thread started\n")
  (void) Sactivate_thread();
  display("thread activated\n")
  Scall0((ptr)p);
  (void) Sdeactivate_thread();
  display("thread deactivated\n")
  (void) Sactivate_thread();
  display("thread reactivated\n")
  Scall0((ptr)p);
  Sdestroy_thread();
  display("thread destroyed\n")
  s_thread_return;
}

static iptr s_backdoor_thread(ptr p) {
  display("creating thread\n");
  return s_thread_create(s_backdoor_thread_start, (void *)p);
}

static ptr s_threads(void) {
  return S_threads;
}

static void s_mutex_acquire(scheme_mutex_t *m) {
  ptr tc = get_thread_context();

  if (m == &S_tc_mutex) {
    S_mutex_acquire(m);
    return;
  }

  if (S_mutex_tryacquire(m) == 0) return;

  if (DISABLECOUNT(tc) == 0) {
    deactivate_thread(tc)
  }
  S_mutex_acquire(m);
  if (DISABLECOUNT(tc) == 0) {
    reactivate_thread(tc)
  }
}

static ptr s_mutex_acquire_noblock(scheme_mutex_t *m) {
  return S_mutex_tryacquire(m) == 0 ? Strue : Sfalse;
}

static void s_condition_broadcast(s_thread_cond_t *c) {
  s_thread_cond_broadcast(c);
}

static void s_condition_signal(s_thread_cond_t *c) {
  s_thread_cond_signal(c);
}
#endif

static ptr s_profile_counters(void) {
  return S_G.profile_counters;
}

/* s_profile_release_counters assumes and maintains the property that each pair's
   tail is not younger than the pair and thereby avoids dirty sets. */
static ptr s_profile_release_counters(void) {
  ptr tossed, *p_keep, *p_toss, ls;
  p_keep = &S_G.profile_counters;
  p_toss = &tossed;
  for (ls = *p_keep; ls != Snil && (MaybeSegInfo(ptr_get_segment(ls)))->generation <= S_G.prcgeneration; ls = Scdr(ls)) {
    if (Sbwp_objectp(CAAR(ls))) {
      *p_toss = ls;
      p_toss = &Scdr(ls);
    } else {
      *p_keep = ls;
      p_keep = &Scdr(ls);
    }
  }
  *p_keep = ls;
  *p_toss = Snil;
  S_G.prcgeneration = 0;
  return tossed;
}

void S_dump_tc(ptr tc) {
  INT i;

  printf("AC0=%p AC1=%p SFP=%p CP=%p\n", AC0(tc), AC1(tc), SFP(tc), CP(tc));
  printf("ESP=%p AP=%p EAP=%p\n", ESP(tc), AP(tc), EAP(tc));
  printf("TRAP=%p XP=%p YP=%p REAL_EAP=%p\n", TRAP(tc), XP(tc), YP(tc), REAL_EAP(tc));
  printf("CCHAIN=%p RANDOMSEED=%ld SCHEMESTACK=%p STACKCACHE=%p\n", CCHAIN(tc), (long)RANDOMSEED(tc), SCHEMESTACK(tc), STACKCACHE(tc));
  printf("STACKLINK=%p SCHEMESTACKSIZE=%ld WINDERS=%p U=%p\n", STACKLINK(tc), (long)SCHEMESTACKSIZE(tc), WINDERS(tc), U(tc));
  printf("V=%p W=%p X=%p Y=%p\n", V(tc), W(tc), X(tc), Y(tc));
  printf("SOMETHING=%p KBDPEND=%p SIGPEND=%p TIMERTICKS=%p\n", SOMETHINGPENDING(tc), KEYBOARDINTERRUPTPENDING(tc), SIGNALINTERRUPTPENDING(tc), TIMERTICKS(tc));
  printf("DISABLECOUNT=%p PARAMETERS=%p\n", DISABLECOUNT(tc), PARAMETERS(tc));
  for (i = 0 ; i < virtual_register_count ; i += 1) {
    printf("VIRTREG[%d]=%p", i, VIRTREG(tc, i));
    if ((i & 0x11) == 0x11 || i == virtual_register_count - 1) printf("\n");
  }
  fflush(stdout);
}

void S_prim5_init(void) {
    if (!S_boot_time) return;

#ifdef PTHREADS
    Sforeign_symbol("(cs)fork_thread", (void *)S_fork_thread);
    Sforeign_symbol("(cs)make_mutex", (void *)S_make_mutex);
    Sforeign_symbol("(cs)mutex_free", (void *)S_mutex_free);
    Sforeign_symbol("(cs)backdoor_thread", (void *)s_backdoor_thread);
    Sforeign_symbol("(cs)threads", (void *)s_threads);
    Sforeign_symbol("(cs)mutex_acquire", (void *)s_mutex_acquire);
    Sforeign_symbol("(cs)mutex_release", (void *)S_mutex_release);
    Sforeign_symbol("(cs)mutex_acquire_noblock", (void *)s_mutex_acquire_noblock);
    Sforeign_symbol("(cs)make_condition", (void *)S_make_condition);
    Sforeign_symbol("(cs)condition_free", (void *)S_condition_free);
    Sforeign_symbol("(cs)condition_broadcast", (void *)s_condition_broadcast);
    Sforeign_symbol("(cs)condition_signal", (void *)s_condition_signal);
    Sforeign_symbol("(cs)condition_wait", (void *)S_condition_wait);
#endif
    Sforeign_symbol("(cs)s_addr_in_heap", (void *)s_addr_in_heap);
    Sforeign_symbol("(cs)s_ptr_in_heap", (void *)s_ptr_in_heap);
    Sforeign_symbol("(cs)generation", (void *)s_generation);
    Sforeign_symbol("(cs)s_fltofx", (void *)s_fltofx);
    Sforeign_symbol("(cs)s_weak_cons", (void *)S_weak_cons);
    Sforeign_symbol("(cs)s_weak_pairp", (void *)s_weak_pairp);
    Sforeign_symbol("(cs)s_ephemeron_cons", (void *)s_ephemeron_cons);
    Sforeign_symbol("(cs)s_ephemeron_pairp", (void *)s_ephemeron_pairp);
    Sforeign_symbol("(cs)continuation_depth", (void *)S_continuation_depth);
    Sforeign_symbol("(cs)single_continuation", (void *)S_single_continuation);
    Sforeign_symbol("(cs)c_exit", (void *)c_exit);
    Sforeign_symbol("(cs)s_set_collect_trip_bytes", (void *)s_set_collect_trip_bytes);
    Sforeign_symbol("(cs)s_oblist", (void *)s_oblist);
    Sforeign_symbol("(cs)s_showalloc", (void *)s_showalloc);
    Sforeign_symbol("(cs)s_system", (void *)s_system);
    Sforeign_symbol("(cs)s_process", (void *)s_process);
    Sforeign_symbol("(cs)s_set_code_byte", (void *)s_set_code_byte);
    Sforeign_symbol("(cs)s_set_code_word", (void *)s_set_code_word);
    Sforeign_symbol("(cs)s_set_code_long", (void *)s_set_code_long);
    Sforeign_symbol("(cs)s_set_code_quad", (void *)s_set_code_quad);
    Sforeign_symbol("(cs)s_set_reloc", (void *)s_set_reloc);
    Sforeign_symbol("(cs)get_code_obj", (void *)S_get_code_obj);
    Sforeign_symbol("(cs)s_flush_instruction_cache", (void *)s_flush_instruction_cache);
    Sforeign_symbol("(cs)s_make_reloc_table", (void *)s_make_reloc_table);
    Sforeign_symbol("(cs)s_make_closure", (void *)s_make_closure);
    Sforeign_symbol("(cs)s_intern", (void *)s_intern);
    Sforeign_symbol("(cs)s_intern2", (void *)s_intern2);
    Sforeign_symbol("(cs)s_intern3", (void *)s_intern3);
    Sforeign_symbol("(cs)s_strings_to_gensym", (void *)s_strings_to_gensym);
    Sforeign_symbol("(cs)s_intern_gensym", (void *)S_intern_gensym);
    Sforeign_symbol("(cs)cputime", (void *)S_cputime);
    Sforeign_symbol("(cs)realtime", (void *)S_realtime);
    Sforeign_symbol("(cs)clock_gettime", (void *)S_clock_gettime);
    Sforeign_symbol("(cs)gmtime", (void *)S_gmtime);
    Sforeign_symbol("(cs)asctime", (void *)S_asctime);
    Sforeign_symbol("(cs)mktime", (void *)S_mktime);
    Sforeign_symbol("(cs)unique_id", (void *)S_unique_id);
    Sforeign_symbol("(cs)file_existsp", (void *)S_file_existsp);
    Sforeign_symbol("(cs)file_regularp", (void *)S_file_regularp);
    Sforeign_symbol("(cs)file_directoryp", (void *)S_file_directoryp);
    Sforeign_symbol("(cs)file_symbolic_linkp", (void *)S_file_symbolic_linkp);
    Sforeign_symbol("(cs)delete_file", (void *)s_delete_file);
    Sforeign_symbol("(cs)delete_directory", (void *)s_delete_directory);
    Sforeign_symbol("(cs)rename_file", (void *)s_rename_file);
    Sforeign_symbol("(cs)mkdir", (void *)s_mkdir);
    Sforeign_symbol("(cs)chmod", (void *)s_chmod);
    Sforeign_symbol("(cs)getmod", (void *)s_getmod);
    Sforeign_symbol("(cs)path_atime", (void *)s_path_atime);
    Sforeign_symbol("(cs)path_ctime", (void *)s_path_ctime);
    Sforeign_symbol("(cs)path_mtime", (void *)s_path_mtime);
    Sforeign_symbol("(cs)fd_atime", (void *)s_fd_atime);
    Sforeign_symbol("(cs)fd_ctime", (void *)s_fd_ctime);
    Sforeign_symbol("(cs)fd_mtime", (void *)s_fd_mtime);
    Sforeign_symbol("(cs)fd_regularp", (void *)s_fd_regularp);
    Sforeign_symbol("(cs)nanosleep", (void *)s_nanosleep);
    Sforeign_symbol("(cs)getpid", (void *)s_getpid);
    Sforeign_symbol("(cs)fasl_read", (void *)S_fasl_read);
    Sforeign_symbol("(cs)bv_fasl_read", (void *)S_bv_fasl_read);
    Sforeign_symbol("(cs)s_decode_float", (void *)s_decode_float);

    Sforeign_symbol("(cs)new_open_input_fd", (void *)S_new_open_input_fd);
    Sforeign_symbol("(cs)new_open_output_fd", (void *)S_new_open_output_fd);
    Sforeign_symbol("(cs)new_open_input_output_fd", (void *)S_new_open_input_output_fd);
    Sforeign_symbol("(cs)close_fd", (void *)S_close_fd);
    Sforeign_symbol("(cs)gzxfile_fd", (void *)S_gzxfile_fd);
    Sforeign_symbol("(cs)compress_input_fd", (void *)S_compress_input_fd);
    Sforeign_symbol("(cs)compress_output_fd", (void *)S_compress_output_fd);

    Sforeign_symbol("(cs)bytevector_read", (void*)S_bytevector_read);
    Sforeign_symbol("(cs)bytevector_read_nb", (void*)S_bytevector_read_nb);
    Sforeign_symbol("(cs)bytevector_write", (void*)S_bytevector_write);
    Sforeign_symbol("(cs)put_byte", (void*)S_put_byte);
    Sforeign_symbol("(cs)get_fd_pos", (void*)S_get_fd_pos);
    Sforeign_symbol("(cs)set_fd_pos", (void*)S_set_fd_pos);
    Sforeign_symbol("(cs)get_fd_non_blocking", (void*)S_get_fd_non_blocking);
    Sforeign_symbol("(cs)set_fd_non_blocking", (void*)S_set_fd_non_blocking);
    Sforeign_symbol("(cs)get_fd_length", (void*)S_get_fd_length);
    Sforeign_symbol("(cs)set_fd_length", (void*)S_set_fd_length);

    Sforeign_symbol("(cs)bytevector_compress_size", (void*)S_bytevector_compress_size);
    Sforeign_symbol("(cs)bytevector_compress", (void*)S_bytevector_compress);
    Sforeign_symbol("(cs)bytevector_uncompress", (void*)S_bytevector_uncompress);

    Sforeign_symbol("(cs)logand", (void *)S_logand);
    Sforeign_symbol("(cs)logbitp", (void *)S_logbitp);
    Sforeign_symbol("(cs)logbit0", (void *)S_logbit0);
    Sforeign_symbol("(cs)logbit1", (void *)S_logbit1);
    Sforeign_symbol("(cs)logtest", (void *)S_logtest);
    Sforeign_symbol("(cs)logor", (void *)S_logor);
    Sforeign_symbol("(cs)logxor", (void *)S_logxor);
    Sforeign_symbol("(cs)lognot", (void *)S_lognot);
    Sforeign_symbol("(cs)fxmul", (void *)s_fxmul);
    Sforeign_symbol("(cs)fxdiv", (void *)s_fxdiv);
    Sforeign_symbol("(cs)s_big_negate", (void *)S_big_negate);
    Sforeign_symbol("(cs)add", (void *)S_add);
    Sforeign_symbol("(cs)gcd", (void *)S_gcd);
    Sforeign_symbol("(cs)mul", (void *)S_mul);
    Sforeign_symbol("(cs)s_ash", (void *)S_ash);
    Sforeign_symbol("(cs)s_big_positive_bit_field", (void *)S_big_positive_bit_field);
    Sforeign_symbol("(cs)s_big_eq", (void *)S_big_eq);
    Sforeign_symbol("(cs)s_big_lt", (void *)S_big_lt);
    Sforeign_symbol("(cs)s_bigoddp", (void *)s_bigoddp);
    Sforeign_symbol("(cs)s_div", (void *)S_div);
    Sforeign_symbol("(cs)s_float", (void *)s_float);
    Sforeign_symbol("(cs)s_flrandom", (void *)s_flrandom);
    Sforeign_symbol("(cs)s_fxrandom", (void *)s_fxrandom);
    Sforeign_symbol("(cs)s_integer_length", (void *)S_integer_length);
    Sforeign_symbol("(cs)s_big_first_bit_set", (void *)S_big_first_bit_set);
    Sforeign_symbol("(cs)s_make_code", (void *)s_make_code);
    Sforeign_symbol("(cs)s_random_seed", (void *)s_random_seed);
    Sforeign_symbol("(cs)s_set_code_long2", (void *)s_set_code_long2);
    Sforeign_symbol("(cs)s_set_random_seed", (void *)s_set_random_seed);
    Sforeign_symbol("(cs)ss_trunc", (void *)S_trunc);
    Sforeign_symbol("(cs)ss_trunc_rem", (void *)s_trunc_rem);
    Sforeign_symbol("(cs)sub", (void *)S_sub);
    Sforeign_symbol("(cs)rem", (void *)S_rem);
#ifdef GETWD
    Sforeign_symbol("(cs)s_getwd", (void *)s_getwd);
#endif
    Sforeign_symbol("(cs)s_chdir", (void *)s_chdir);
#ifdef WIN32
    Sforeign_symbol("(cs)find_files", (void *)S_find_files);
#else
    Sforeign_symbol("(cs)directory_list", (void *)S_directory_list);
#endif
    Sforeign_symbol("(cs)dequeue_scheme_signals", (void *)S_dequeue_scheme_signals);
    Sforeign_symbol("(cs)register_scheme_signal", (void *)S_register_scheme_signal);

    Sforeign_symbol("(cs)mod", (void *)s_mod);
    Sforeign_symbol("(cs)exp", (void *)s_exp);
    Sforeign_symbol("(cs)log", (void *)s_log);
    Sforeign_symbol("(cs)pow", (void *)s_pow);
    Sforeign_symbol("(cs)sqrt", (void *)s_sqrt);
    Sforeign_symbol("(cs)sin", (void *)s_sin);
    Sforeign_symbol("(cs)cos", (void *)s_cos);
    Sforeign_symbol("(cs)tan", (void *)s_tan);
    Sforeign_symbol("(cs)asin", (void *)s_asin);
    Sforeign_symbol("(cs)acos", (void *)s_acos);
    Sforeign_symbol("(cs)atan", (void *)s_atan);
    Sforeign_symbol("(cs)atan2", (void *)s_atan2);
    Sforeign_symbol("(cs)sinh", (void *)s_sinh);
    Sforeign_symbol("(cs)cosh", (void *)s_cosh);
    Sforeign_symbol("(cs)tanh", (void *)s_tanh);
    Sforeign_symbol("(cs)floor", (void *)s_floor);
    Sforeign_symbol("(cs)ceil", (void *)s_ceil);
    Sforeign_symbol("(cs)hypot", (void *)s_hypot);

#ifdef ARCHYPERBOLIC
    Sforeign_symbol("(cs)asinh", (void *)s_asinh);
    Sforeign_symbol("(cs)acosh", (void *)s_acosh);
    Sforeign_symbol("(cs)atanh", (void *)s_atanh);
#endif /* ARCHHYPERBOLIC */

#ifdef LOG1P
    Sforeign_symbol("(cs)log1p", (void *)s_log1p);
#endif /* LOG1P */

    Sforeign_symbol("(cs)s_get_reloc", (void *)s_get_reloc);
    Sforeign_symbol("(cs)getenv", (void *)s_getenv);
    Sforeign_symbol("(cs)putenv", (void *)s_putenv);
    Sforeign_symbol("(cs)byte-copy", (void *)s_byte_copy);
    Sforeign_symbol("(cs)ptr-copy", (void *)s_ptr_copy);
    Sforeign_symbol("(cs)boot-error", (void *)S_boot_error);
    Sforeign_symbol("(cs)s_tlv", (void *)s_tlv);
    Sforeign_symbol("(cs)s_stlv", (void *)s_stlv);
    Sforeign_symbol("(cs)s_test_schlib", (void *)s_test_schlib);
    Sforeign_symbol("(cs)Sinteger_value", (void *)Sinteger_value);
    Sforeign_symbol("(cs)Sinteger32_value", (void *)Sinteger32_value);
    Sforeign_symbol("(cs)Sinteger64_value", (void *)Sinteger64_value);
    Sforeign_symbol("(cs)s_breakhere", (void *)s_breakhere);
    Sforeign_symbol("(cs)s_interactivep", (void *)s_interactivep);
    Sforeign_symbol("(cs)same_devicep", (void *)s_same_devicep);
    Sforeign_symbol("(cs)malloc", (void *)s_malloc);
    Sforeign_symbol("(cs)free", (void *)s_free);
#ifdef FEATURE_ICONV
    Sforeign_symbol("(cs)s_iconv_open", (void *)s_iconv_open);
    Sforeign_symbol("(cs)s_iconv_close", (void *)s_iconv_close);
    Sforeign_symbol("(cs)s_iconv_from_string", (void *)s_iconv_from_string);
    Sforeign_symbol("(cs)s_iconv_to_string", (void *)s_iconv_to_string);
#endif
    Sforeign_symbol("(cs)s_strerror", (void *)S_strerror);
    Sforeign_symbol("(cs)s_errno", (void *)s_errno);
#ifdef WIN32
    Sforeign_symbol("(cs)s_multibytetowidechar", (void *)s_multibytetowidechar);
    Sforeign_symbol("(cs)s_widechartomultibyte", (void *)s_widechartomultibyte);
#endif
    Sforeign_symbol("(cs)s_profile_counters", (void *)s_profile_counters);
    Sforeign_symbol("(cs)s_profile_release_counters", (void *)s_profile_release_counters);
}

static ptr s_get_reloc(ptr co) {
  ptr t, ls; uptr a, m, n;

  require(Scodep(co),"s_get_reloc","~s is not a code object",co);
  ls = Snil;
  t = CODERELOC(co);
  m = RELOCSIZE(t);
  a = 0;
  n = 0;
  while (n < m) {
    uptr entry, item_off, code_off; ptr obj;
    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;
    obj = S_get_code_obj(RELOC_TYPE(entry), co, a, item_off);
    if (!Sfixnump(obj)) {
      ptr x;
      for (x = ls; ; x = Scdr(x)) {
        if (x == Snil) {
          ls = Scons(obj,ls);
          break;
        } else if (Scar(x) == obj)
          break;
      }
    }
  }
  return ls;
}

static void s_byte_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt) {
  void *srcaddr = (void *)((iptr)src + srcoff);
  void *dstaddr = (void *)((iptr)dst + dstoff);
  if (dst != src)
     memcpy(dstaddr, srcaddr, cnt);
  else
     memmove(dstaddr, srcaddr, cnt);
}

static void s_ptr_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt) {
  void *srcaddr = (void *)((iptr)src + srcoff);
  void *dstaddr = (void *)((iptr)dst + dstoff);
  cnt = cnt << log2_ptr_bytes;
  if (dst != src)
     memcpy(dstaddr, srcaddr, cnt);
  else
     memmove(dstaddr, srcaddr, cnt);
}

/* these are used only for testing */
static ptr s_tlv(ptr x) {
  return Stop_level_value(x);
}

static void s_stlv(ptr x, ptr v) {
  Sset_top_level_value(x, v);
}

#define SCHLIBTEST(expr) {\
  test += 1;\
  if (!(expr)) S_error1("s_test_schlib", "test ~s failed", FIX(test));\
}

static void s_test_schlib(void) {
  INT test = 0;
  I32 n1 = 0x73215609;
  I64 n2 = n1 * 37;
  I32 n3 = (I32)1<<31;
  I64 n4 = (I64)1<<63;
  I32 n5 = -1;

  SCHLIBTEST(Sinteger_value(Sinteger(n1)) == n1)
  SCHLIBTEST(Sinteger_value(Sinteger(-n1)) == -n1)
  SCHLIBTEST(Sinteger_value(Sunsigned(n1)) == n1)
  SCHLIBTEST(Sinteger_value(Sunsigned(-n1)) == -n1)
  SCHLIBTEST(Sinteger32_value(Sinteger32(n1)) == n1)
  SCHLIBTEST(Sinteger32_value(Sinteger32(-n1)) == -n1)
  SCHLIBTEST(Sinteger32_value(Sunsigned32(n1)) == n1)
  SCHLIBTEST(Sinteger32_value(Sunsigned32(-n1)) == -n1)
  SCHLIBTEST(Sinteger64_value(Sinteger64(n1)) == n1)
  SCHLIBTEST(Sinteger64_value(Sinteger64(-n1)) == -n1)
  SCHLIBTEST(Sinteger64_value(Sunsigned64(n1)) == n1)
  SCHLIBTEST(Sinteger64_value(Sunsigned64(-n1)) == -n1)
#if (ptr_bits == 64)
  SCHLIBTEST(Sinteger_value(Sinteger(n2)) == n2)
  SCHLIBTEST(Sinteger_value(Sinteger(-n2)) == -n2)
  SCHLIBTEST(Sinteger_value(Sunsigned(n2)) == n2)
  SCHLIBTEST(Sinteger_value(Sunsigned(-n2)) == -n2)
#endif
  SCHLIBTEST(Sinteger64_value(Sinteger64(n2)) == n2)
  SCHLIBTEST(Sinteger64_value(Sinteger64(-n2)) == -n2)
  SCHLIBTEST(Sinteger64_value(Sunsigned64(n2)) == n2)
  SCHLIBTEST(Sinteger64_value(Sunsigned64(-n2)) == -n2)

  SCHLIBTEST(Sinteger_value(Sinteger(n3)) == n3)
  SCHLIBTEST(Sinteger_value(Sunsigned(n3)) == n3)
  SCHLIBTEST(Sinteger32_value(Sinteger32(n3)) == n3)
  SCHLIBTEST(Sinteger32_value(Sunsigned32(n3)) == n3)
  SCHLIBTEST(Sinteger64_value(Sinteger64(n3)) == n3)
  SCHLIBTEST(Sinteger64_value(Sunsigned64(n3)) == n3)
#if (ptr_bits == 64)
  SCHLIBTEST(Sinteger_value(Sunsigned(n4)) == n4)
  SCHLIBTEST(Sinteger_value(Sinteger(n4)) == n4)
  SCHLIBTEST(Sinteger_value(Sunsigned(n4)) == n4)
#endif
  SCHLIBTEST(Sinteger64_value(Sinteger64(n4)) == n4)
  SCHLIBTEST(Sinteger64_value(Sunsigned64(n4)) == n4)

  SCHLIBTEST(Sinteger_value(Sinteger(n5)) == n5)
  SCHLIBTEST(Sinteger_value(Sinteger(-n5)) == -n5)
  SCHLIBTEST(Sinteger_value(Sunsigned(n5)) == n5)
  SCHLIBTEST(Sinteger_value(Sunsigned(-n5)) == -n5)
  SCHLIBTEST(Sinteger32_value(Sinteger32(n5)) == n5)
  SCHLIBTEST(Sinteger32_value(Sinteger32(-n5)) == -n5)
  SCHLIBTEST(Sinteger32_value(Sunsigned32(n5)) == n5)
  SCHLIBTEST(Sinteger32_value(Sunsigned32(-n5)) == -n5)
  SCHLIBTEST(Sinteger64_value(Sinteger64(n5)) == n5)
  SCHLIBTEST(Sinteger64_value(Sinteger64(-n5)) == -n5)
  SCHLIBTEST(Sinteger64_value(Sunsigned64(n5)) == n5)
  SCHLIBTEST(Sinteger64_value(Sunsigned64(-n5)) == -n5)
}

/* place to break when debugging */
static void s_breakhere(UNUSED ptr x) {
  return;
}

static IBOOL s_interactivep(void) {
  static INT interactivep = -1;
  if (interactivep == -1) {
#ifdef WIN32
    HANDLE hStdout, hStdin; 
    CONSOLE_SCREEN_BUFFER_INFO csbiInfo; 
    DWORD InMode, OutMode;
    interactivep =
       (hStdin = GetStdHandle(STD_INPUT_HANDLE)) != INVALID_HANDLE_VALUE
       && (hStdout = GetStdHandle(STD_OUTPUT_HANDLE)) != INVALID_HANDLE_VALUE
       && GetConsoleScreenBufferInfo(hStdout, &csbiInfo)
       && GetConsoleMode(hStdin, &InMode)
       && GetConsoleMode(hStdout, &OutMode);
#else /* WIN32 */
    interactivep = isatty(0) && isatty(1);
#endif /* WIN32 */
  }
  return interactivep;
}

static IBOOL s_same_devicep(INT fd1, INT fd2) {
#ifdef WIN32
  HANDLE h1, h2; DWORD mode1, mode2;
  if ((h1 = (HANDLE)_get_osfhandle(fd1)) != INVALID_HANDLE_VALUE) 
    if ((h2 = (HANDLE)_get_osfhandle(fd2)) != INVALID_HANDLE_VALUE)
      switch (GetFileType(h1)) {
        case FILE_TYPE_CHAR:
          if (GetFileType(h2) == FILE_TYPE_CHAR)
            return GetConsoleMode(h1, &mode1) && GetConsoleMode(h2, &mode2);
          break;
        case FILE_TYPE_DISK:
          if (GetFileType(h2) == FILE_TYPE_DISK) {
            BY_HANDLE_FILE_INFORMATION info1, info2;
            if (GetFileInformationByHandle(h1, &info1) && GetFileInformationByHandle(h1, &info2))
              return info1.dwVolumeSerialNumber == info2.dwVolumeSerialNumber 
                  && info1.nFileIndexHigh == info2.nFileIndexHigh 
                  && info1.nFileIndexLow == info2.nFileIndexLow;
          }
          break;
        case FILE_TYPE_PIPE:
         /* no clue */
          break;
        default: break;
      }
#else /* WIN32 */
  struct STATBUF statbuf1, statbuf2;
  if (FSTAT(fd1, &statbuf1) == 0 && FSTAT(fd2, &statbuf2) == 0)
    return statbuf1.st_ino == statbuf2.st_ino;
#endif /* WIN32 */

  return 0;
}

static uptr s_malloc(iptr n) {
  void *p;
  if ((p = malloc((size_t)n)) == NULL) {
    ptr msg = S_strerror(errno);

    if (msg != Sfalse)
      S_error1("foreign-alloc", "~a", msg);
    else
      S_error("foreign-alloc", "malloc failed");
  }
  return (uptr)p;
}

static void s_free(uptr addr) {
  free((void *)addr);
}

#ifdef FEATURE_ICONV
#ifdef WIN32
typedef void *iconv_t;
typedef __declspec(dllimport) iconv_t (*iconv_open_ft)(const char *tocode, const char *fromcode);
typedef __declspec(dllimport) size_t (*iconv_ft)(iconv_t cd, char **inbuf, size_t *inbytesleft, char **outbuf, size_t *outbytesleft);
typedef __declspec(dllimport) int (*iconv_close_ft)(iconv_t cd);

static iconv_open_ft iconv_open_f = (iconv_open_ft)0;
static iconv_ft iconv_f = (iconv_ft)0;
static iconv_close_ft iconv_close_f = (iconv_close_ft)0;
#define ICONV_OPEN iconv_open_f
#define ICONV iconv_f
#define ICONV_CLOSE iconv_close_f
#else
#include <iconv.h>
#define ICONV_OPEN iconv_open
#define ICONV iconv
#define ICONV_CLOSE iconv_close
#endif

#ifdef WIN32
static ptr s_iconv_trouble(HMODULE h, const char *what) {
  wchar_t dllw[PATH_MAX];
  char *dll;
  size_t n;
  char *msg;
  ptr r;
  if (0 != GetModuleFileNameW(h, dllw, PATH_MAX))
    dll = Swide_to_utf8(dllw);
  else
    dll = NULL;
  FreeLibrary(h);
  n = strlen(what) + strlen(dll) + 17;
  msg = (char *)malloc(n);
  sprintf_s(msg, n, "cannot find %s in %s", what, dll);
  free(dll);
  r = Sstring_utf8(msg, -1);
  free(msg);
  return r;
}
#endif /* WIN32 */

static ptr s_iconv_open(const char *tocode, const char *fromcode) {
  iconv_t cd;
#ifdef WIN32
  static int iconv_is_loaded = 0;
  if (!iconv_is_loaded) {
    HMODULE h = LoadLibraryW(L"iconv.dll");
    if (h == NULL) h = LoadLibraryW(L"libiconv.dll");
    if (h == NULL) h = LoadLibraryW(L"libiconv-2.dll");
    if (h == NULL) h = LoadLibraryW(L".\\iconv.dll");
    if (h == NULL) h = LoadLibraryW(L".\\libiconv.dll");
    if (h == NULL) h = LoadLibraryW(L".\\libiconv-2.dll");
    if (h == NULL) return Sstring("cannot load iconv.dll, libiconv.dll, or libiconv-2.dll");
    if ((iconv_open_f = (iconv_open_ft)GetProcAddress(h, "iconv_open")) == NULL &&
        (iconv_open_f = (iconv_open_ft)GetProcAddress(h, "libiconv_open")) == NULL)
      return s_iconv_trouble(h, "iconv_open or libiconv_open");
    if ((iconv_f = (iconv_ft)GetProcAddress(h, "iconv")) == NULL &&
        (iconv_f = (iconv_ft)GetProcAddress(h, "libiconv")) == NULL)
      return s_iconv_trouble(h, "iconv or libiconv");
    if ((iconv_close_f = (iconv_close_ft)GetProcAddress(h, "iconv_close")) == NULL &&
        (iconv_close_f = (iconv_close_ft)GetProcAddress(h, "libiconv_close")) == NULL)
      return s_iconv_trouble(h, "iconv_close or libiconv_close");
    iconv_is_loaded = 1;
  }
#endif /* WIN32 */

  if ((cd = ICONV_OPEN(tocode, fromcode)) == (iconv_t)-1) return Sfalse;

 /* have to be able to cast to int, since iconv_open can return (iconv_t)-1 */
  return Sunsigned((uptr)cd);
}

static void s_iconv_close(uptr cd) {
  ICONV_CLOSE((iconv_t)cd);
}

#define ICONV_BUFSIZ 400

static ptr s_iconv_from_string(uptr cd, ptr in, uptr i, uptr iend, ptr out, uptr o, uptr oend) {
  U32 buf[ICONV_BUFSIZ];
  char *inbuf, *outbuf;
  size_t inbytesleft, outbytesleft;
  uptr inmax, k, new_i, new_o;

  outbuf = (char *)&BVIT(out, o);
  outbytesleft = oend - o;

  inmax = iend - i;
  if (inmax > ICONV_BUFSIZ) inmax = ICONV_BUFSIZ;
  if (inmax > outbytesleft) inmax = outbytesleft;
  for (k = 0; k < inmax; k += 1) buf[k] = Sstring_ref(in, i + k);

  inbuf = (char *)buf;
  inbytesleft = inmax * sizeof(string_char);

 /* we ignore the iconv return value because we consider success to be the consumption
    of input or production of output.  we set errno to 0 before calling iconv, even though
    it should be set properly if neither input is consumed nor output is produced, because,
    under Windows, the iconv dll might have been linked against a different C runtime
    and might therefore set a different errno */
  errno = 0;
  ICONV((iconv_t)cd, (ICONV_INBUF_TYPE)&inbuf, &inbytesleft, &outbuf, &outbytesleft);
  new_i = i + inmax - inbytesleft / sizeof(string_char);
  new_o = oend - outbytesleft;
  if (new_i != i || new_o != o) return Scons(Sinteger(new_i), Sinteger(new_o));

  switch (errno) {
    case EILSEQ: return FIX(SICONV_INVALID);
    case EINVAL: return FIX(SICONV_INCOMPLETE);
    case E2BIG: return FIX(SICONV_NOROOM);
    default: return FIX(SICONV_DUNNO);
  }
}

static ptr s_iconv_to_string(uptr cd, ptr in, uptr i, uptr iend, ptr out, uptr o, uptr oend) {
  U32 buf[ICONV_BUFSIZ];
  char *inbuf, *outbuf;
  size_t inbytesleft, outbytesleft;
  uptr outmax, k, new_i, new_o;
  
  inbuf = (char *)&BVIT(in, i);
  inbytesleft = iend - i;

  outmax = oend - o;
  if (outmax > ICONV_BUFSIZ) outmax = ICONV_BUFSIZ;
  if (outmax > inbytesleft) outmax = inbytesleft;

  outbuf = (char *)buf;
  outbytesleft = outmax * sizeof(string_char);

 /* see the comment about the iconv return value and errno in s_iconv_from_string */
  errno = 0;
  ICONV((iconv_t)cd, (ICONV_INBUF_TYPE)&inbuf, &inbytesleft, &outbuf, &outbytesleft);

  outmax -= outbytesleft / sizeof(string_char);
  for (k = 0; k < outmax; k += 1) Sstring_set(out, o + k, buf[k]);
  new_i = iend - inbytesleft;
  new_o = o + outmax;
  if (new_i != i || new_o != o) return Scons(Sinteger(new_i), Sinteger(new_o));

  switch (errno) {
    case EILSEQ: return FIX(SICONV_INVALID);
    case EINVAL: return FIX(SICONV_INCOMPLETE);
    case E2BIG: return FIX(SICONV_NOROOM);
    default: return FIX(SICONV_DUNNO);
  }
}
#endif /* FEATURE_ICONV */

#ifdef WIN32
static ptr s_multibytetowidechar(unsigned cp, ptr inbv) {
  uptr inbytes; int outwords; ptr outbv;
  
  inbytes = Sbytevector_length(inbv);

#if (ptr_bits > int_bits)
  if ((int)inbytes != inbytes) S_error1("multibyte->string", "input size ~s is beyond MultiByteToWideChar's limit", Sinteger(inbytes));
#endif

  if ((outwords = MultiByteToWideChar(cp, 0, &BVIT(inbv,0), (int)inbytes, NULL, 0)) == 0)
    S_error1("multibyte->string", "conversion failed: ~a", S_LastErrorString());

  outbv = S_bytevector(outwords * 2);

  if (MultiByteToWideChar(cp, 0, &BVIT(inbv,0), (int)inbytes, (wchar_t *)&BVIT(outbv, 0), outwords) == 0)
    S_error1("multibyte->string", "conversion failed: ~a", S_LastErrorString());
  
  return outbv;
}

static ptr s_widechartomultibyte(unsigned cp, ptr inbv) {
  uptr inwords; int outbytes; ptr outbv;

  inwords = Sbytevector_length(inbv) / 2;

#if (ptr_bits > int_bits)
  if ((int)inwords != inwords) S_error1("multibyte->string", "input size ~s is beyond WideCharToMultiByte's limit", Sinteger(inwords));
#endif

  if ((outbytes = WideCharToMultiByte(cp, 0, (wchar_t *)&BVIT(inbv,0), (int)inwords, NULL, 0, NULL, NULL)) == 0)
    S_error1("string->multibyte", "conversion failed: ~a", S_LastErrorString());

  outbv = S_bytevector(outbytes);

  if (WideCharToMultiByte(cp, 0, (wchar_t *)&BVIT(inbv,0), (int)inwords, &BVIT(outbv, 0), outbytes, NULL, NULL) == 0)
    S_error1("string->multibyte", "conversion failed: ~a", S_LastErrorString());
  
  return outbv;  
}
#endif /* WIN32 */