skint/src/n.sf

;------------------------------------------------------------------------------
;
;  -C extracts from Large RNRS compatibility library for #F, fixnum/flonums 
;
;------------------------------------------------------------------------------


;------------------------------------------------------------------------------

; scheme data types 


(%definition "/* basic object representation */")

; there are two types of immediate objects: those with 30 bits of payload data
; and no secondary tag (lower two bits are 11), and those with 3-bit tag and 24 
; bits of payload data (lower two bits are 01); in both cases lsb is 1

(%definition "#ifdef NAN_BOXING")

(%definition "#define isim0(o)    (((o) & 0xffffffff00000003ULL) == 3) /* 30 bits of payload */")
(%definition "#define isimm(o, t) (((o) & 0xffffffff000000ffULL) == (((t) << 2) | 1)) /* 24 */")
(%definition "#ifdef NDEBUG
  #define getim0s(o) (long)(((((int32_t)(o) >> 2) & 0x3fffffff) ^ 0x20000000) - 0x20000000)
  #define getimmu(o, t) (long)(((o) >> 8) & 0xffffff)
#else
  extern long getim0s(obj o);
  extern long getimmu(obj o, int t);
#endif")
(%localdef "#ifndef NDEBUG
long getim0s(obj o) {
  assert(isim0(o));
  return (int32_t)(((((uint32_t)o >> 2) & 0x3fffffff) ^ 0x20000000) - 0x20000000);
}
long getimmu(obj o, int t) {
  assert(isimm((o), t));
  return (long)(((uint32_t)o >> 8) & 0xffffff);
}
#endif")
(%definition "#define mkim0(v) ((obj)((((v) & 0x000000003fffffffULL) << 2) | 3))")
(%definition "#define mkimm(v, t) ((obj)((((v) & 0x0000000000ffffffULL) << 8) | ((t) << 2) | 1))")

(%definition "#else")

(%definition "#define isim0(o)    (((o) & 3) == 3)")
(%definition "#define isimm(o, t) (((o) & 0xff) == (((t) << 2) | 1))")
(%definition "#ifdef NDEBUG
  #define getim0s(o) (long)(((((int)(o) >> 2) & 0x3fffffff) ^ 0x20000000) - 0x20000000)
  #define getimmu(o, t) (long)(((o) >> 8) & 0xffffff)
#else
  extern long getim0s(obj o);
  extern long getimmu(obj o, int t);
#endif")
(%localdef "#ifndef NDEBUG
long getim0s(obj o) {
  assert(isim0(o));
  return (int)((((o >> 2) & 0x3fffffff) ^ 0x20000000) - 0x20000000);
}
long getimmu(obj o, int t) {
  assert(isimm(o, t));
  return (long)((o >> 8) & 0xffffff);
}
#endif")
(%definition "#define mkim0(o) (obj)((((o) & 0x3fffffff) << 2) | 3)")
(%definition "#define mkimm(o, t) (obj)((((o) & 0xffffff) << 8) | ((t) << 2) | 1)")
(%definition "#define FLONUMS_BOXED")

(%definition "#endif")


; native blocks are 1-element blocks containing a native
; (non-cx) pointer as 0th element and cxtype ptr in block header

(%localdef "#ifndef NDEBUG
int isnative(obj o, cxtype_t *tp) {
  return isobjptr(o) && objptr_from_obj(o)[-1] == (obj)tp; 
}
void *getnative(obj o, cxtype_t *tp) {
  assert(isnative(o, tp));
  return (void*)(*objptr_from_obj(o));
}
#endif")

(%definition "#ifdef NDEBUG
   static int isnative(obj o, cxtype_t *tp) 
     { return isobjptr(o) && objptr_from_obj(o)[-1] == (obj)tp;  }
   #define getnative(o, t) ((void*)(*objptr_from_obj(o)))
#else
  extern int isnative(obj o, cxtype_t *tp);
  extern void *getnative(obj o, cxtype_t *tp);
#endif")



; tagged blocks are heap blocks with runtime int tag as 0th element
; (disjoint from closures which have a foreign pointer as 0th element
; and from typed blocks which have scheme heap pointer as 0th element)

(%definition "extern int istagged(obj o, int t);")
(%localdef "int istagged(obj o, int t) {
  if (!isobjptr(o)) return 0;
  else { obj h = objptr_from_obj(o)[-1];
    return notaptr(h) && size_from_obj(h) >= 1 
      && hblkref(o, 0) == obj_from_size(t); }
}")

(%definition "#ifdef NDEBUG
  #define cktagged(o, t) (o)
  #define taggedlen(o, t) (hblklen(o)-1) 
  #define taggedref(o, t, i) (&hblkref(o, (i)+1))
#else
  extern obj cktagged(obj o, int t);
  extern int taggedlen(obj o, int t);
  extern obj* taggedref(obj o, int t, int i); 
#endif")
(%localdef "#ifndef NDEBUG
obj cktagged(obj o, int t) {
  assert(istagged((o), t));
  return o;
}
int taggedlen(obj o, int t) {
  assert(istagged((o), t));
  return hblklen(o) - 1;
}
obj* taggedref(obj o, int t, int i) {
  int len; assert(istagged((o), t));
  len = hblklen(o);
  assert(i >= 0 && i < len-1);  
  return &hblkref(o, i+1);
}
#endif")



; typed blocks have non-immediate scheme tag as 0th element
; (disjoint from closures and native/tagged blocks)

(%definition "extern int istyped(obj o);")
(%localdef "int istyped(obj o) {
  if (!isobjptr(o)) return 0;
  else { obj h = objptr_from_obj(o)[-1];
    return notaptr(h) && size_from_obj(h) >= 1 
      /* FIXME: manual issymbol() check */
      && isimm(hblkref(o, 0), 4/*SYMBOL_ITAG*/); }
}")

(%definition "#ifdef NDEBUG
  #define cktyped(o, t) (o)
  #define typedtype(o) (&hblkref(o, 0))
  #define typedlen(o) (hblklen(o)-1) 
  #define typedref(o, i) (&hblkref(o, (i)+1))
#else
  extern obj cktyped(obj o);
  extern obj* typedtype(obj o); 
  extern int typedlen(obj o);
  extern obj* typedref(obj o, int i); 
#endif")
(%localdef "#ifndef NDEBUG
obj cktyped(obj o) {
  assert(istyped(o));
  return o;
}
obj* typedtype(obj o) {
  assert(istyped(o));
  return &hblkref(o, 0);
}
int typedlen(obj o) {
  assert(istyped(o));
  return hblklen(o) - 1;
}
obj* typedref(obj o, int i) {
  int len; assert(istyped(o));
  len = hblklen(o);
  assert(i >= 0 && i < len-1);  
  return &hblkref(o, i+1);
}
#endif")


; booleans

; #f is (obj)0, #t is immediate 0 with tag 0 (singular true object)
; this layout is compatible with C conventions (0 = false, 1 = true)
; note that any obj but #f is counted as true in conditionals and that
; bool_from_obj and bool_from_bool are already defined in std prelude


(%definition "/* booleans */")
(%definition "#define TRUE_ITAG 0")  
(%definition "typedef int bool_t;")
(%definition "#define is_bool_obj(o) (!((o) & ~(obj)1))")  
(%definition "#define is_bool_bool(b) ((void)(b), 1)")  
(%definition "#define void_from_bool(b) (void)(b)")
(%definition "#define obj_from_bool(b) ((b) ? mkimm(0, TRUE_ITAG) : 0)")


; void 

; void object redefined as immediate with payload 0 and immediate tag 1


(%definition "/* void */")
(%definition "#define VOID_ITAG 1")  
(%definition "#define mkvoid() mkimm(0, VOID_ITAG)")  
(%definition "#define isvoid(o) ((o) == mkimm(0, VOID_ITAG))")  
(%definition "#undef obj_from_void")
(%definition "#define obj_from_void(v) ((void)(v), mkimm(0, VOID_ITAG))")


; unit

; this is the value to be used when zero results are returned to a context
; where one result is expected; it is analogous to a 0-element tuple

(%definition "/* unit */")
(%definition "#define obj_from_unit() (obj_from_size(0x6DF6F577))")


; numerical helpers

(%definition "/* numbers */")
(%definition "#define FIXNUM_BIT 30")
(%definition "#define FIXNUM_MIN -536870912")
(%definition "#define FIXNUM_MAX 536870911")
(%definition "#ifdef NDEBUG
#define fxneg(x) (-(x))
#define fxabs(x) (labs(x))
#define fxadd(x, y) ((x) + (y))
#define fxsub(x, y) ((x) - (y))
#define fxmul(x, y) ((x) * (y))
/* exact integer division */
#define fxdiv(x, y) ((x) / (y))  
/* truncated division (common/C99) */
#define fxquo(x, y) ((x) / (y))  
#define fxrem(x, y) ((x) % (y))
/* floor division */
static long fxmqu(long x, long y) {
  long q = x / y; return ((x < 0 && y > 0) || (x > 0 && y < 0)) ? q - 1 : q;
}
static long fxmlo(long x, long y) {
  long r = x % y; return ((r < 0 && y > 0) || (r > 0 && y < 0)) ? r + y : r;
}
/* euclidean division */
static long fxeuq(long x, long y) { 
  long q = x / y, r = x % y; return (r < 0) ? ((y > 0) ? q - 1 : q + 1) : q;
}
static long fxeur(long x, long y) {
  long r = x % y; return (r < 0) ? ((y > 0) ? r + y : r - y) : r;
} 
static long fxgcd(long x, long y) {
  long a = labs(x), b = labs(y), c; while (b) c = a%b, a = b, b = c; 
  return a;
} 
#define fxasl(x, y) ((x) << (y))
#define fxasr(x, y) ((x) >> (y))
#define fxflo(f) ((long)(f))
#else
extern long fxneg(long x);
extern long fxabs(long x);
extern long fxadd(long x, long y);
extern long fxsub(long x, long y);
extern long fxmul(long x, long y);
extern long fxdiv(long x, long y);
extern long fxquo(long x, long y);
extern long fxrem(long x, long y);
extern long fxmqu(long x, long y);
extern long fxmlo(long x, long y);
extern long fxeuq(long x, long y);
extern long fxeur(long x, long y);
extern long fxgcd(long x, long y);
extern long fxasl(long x, long y);
extern long fxasr(long x, long y);
extern long fxflo(double f);
#endif")

(%localdef "#ifndef NDEBUG
long fxneg(long x) { 
  assert(x != FIXNUM_MIN); 
  return -x; 
}
long fxabs(long x) { 
  assert(x != FIXNUM_MIN); 
  return labs(x); 
}
long fxadd(long x, long y) { 
  long z = x + y; 
  assert(z >= FIXNUM_MIN && z <= FIXNUM_MAX); 
  return z; 
}
long fxsub(long x, long y) { 
  long z = x - y; 
  assert(z >= FIXNUM_MIN && z <= FIXNUM_MAX); 
  return z; 
}
long fxmul(long x, long y) { 
  double z = (double)x * (double)y;
  assert(z >= FIXNUM_MIN && z <= FIXNUM_MAX);
  return x * y; 
}
/* exact integer division */
long fxdiv(long x, long y) { 
  assert(y); 
  assert(x != FIXNUM_MIN || y != -1);
  assert(x % y == 0);
  return x / y; 
}
/* truncated division (common/C99) */
long fxquo(long x, long y) { 
  assert(y); assert(x != FIXNUM_MIN || y != -1);
  return x / y; 
}
long fxrem(long x, long y) { 
  assert(y);
  return x % y; 
}
/* floor division */
long fxmqu(long x, long y) {
  long q; assert(y); assert(x != FIXNUM_MIN || y != -1);
  q = x / y;
  return ((x < 0 && y > 0) || (x > 0 && y < 0)) ? q - 1 : q;
}
long fxmlo(long x, long y) {
  long r; assert(y); r = x % y;
  return ((r < 0 && y > 0) || (r > 0 && y < 0)) ? r + y : r;
}
/* euclidean division */
long fxeuq(long x, long y) { 
  long q, r; assert(y); assert(x != FIXNUM_MIN || y != -1);
  q = x / y, r = x % y; 
  return (r < 0) ? ((y > 0) ? q - 1 : q + 1) : q;
}
long fxeur(long x, long y) {
  long r; assert(y); r = x % y; 
  return (r < 0) ? ((y > 0) ? r + y : r - y) : r;
} 
long fxgcd(long x, long y) {
  long a = labs(x), b = labs(y), c; 
  while (b) c = a%b, a = b, b = c; 
  assert(a <= FIXNUM_MAX);
  return a;
} 
long fxasl(long x, long y) {
  assert(y >= 0 && y < FIXNUM_BIT); 
  return x << y;
} 
long fxasr(long x, long y) {
  assert(y >= 0 && y < FIXNUM_BIT);
  assert(!y || x >= 0); /* >> of negative x is undefined */ 
  return x >> y;
} 
long fxflo(double f) {
  long l = (long)f; assert((double)l == f);
  assert(l >= FIXNUM_MIN && l <= FIXNUM_MAX);
  return l;
}
#endif")

(%definition "static int flisint(double f) { return f > -HUGE_VAL && f < HUGE_VAL && f == floor(f); }")

(%definition "extern long fxpow(long x, long y);")
(%localdef "long fxpow(long x, long y) { 
  assert(y >= 0);
  retry: if (y == 0) return 1; if (y == 1) return x;
  if (y % 2 == 1) x *= fxpow(x, y-1); 
  else { x *= x; y /= 2; assert(FIXNUM_MIN <= x && x <= FIXNUM_MAX); goto retry; }
  assert(FIXNUM_MIN <= x && x <= FIXNUM_MAX); return x;
}")

(%definition "extern long fxsqrt(long x);")
(%localdef "long fxsqrt(long x) { 
  assert(x >= 0); if (x < 2) return x;
  else { long s = fxsqrt(x >> 2) << 1, l = s + 1; return l*l > x ? s : l; }
}")

(%definition "extern int fxifdv(long x, long y, long *pi, double *pd);")
(%localdef "int fxifdv(long x, long y, long *pi, double *pd) { 
  assert(y); assert(x != FIXNUM_MIN || y != -1);
  if (x % y == 0) { *pi = x / y; return 1; }
  else { *pd = (double)x / (double)y; return 0; }  
}")

(%definition "extern double flquo(double x, double y);")
(%localdef "double flquo(double x, double y) {
  double z; assert(y != 0.0 && flisint(x) && flisint(y));
  modf(x / y,  &z);
  return z;
}")
(%definition "extern double flrem(double x, double y);")
(%localdef "double flrem(double x, double y) {
  assert(y != 0.0 && flisint(x) && flisint(y));
  return fmod(x, y);
}")
(%definition "extern double flmqu(double x, double y);")
(%localdef "double flmqu(double x, double y) {
  assert(y != 0.0 && flisint(x) && flisint(y));
  return floor(x / y);
}")
(%definition "extern double flmlo(double x, double y);")
(%localdef "double flmlo(double x, double y) {
  assert(y != 0.0 && flisint(x) && flisint(y));
  return x - y * floor(x / y);
}")
(%definition "extern double flgcd(double x, double y);")
(%localdef "double flgcd(double x, double y) {
  double a = fabs(x), b = fabs(y), c; 
  assert(flisint(a) && flisint(b));
  while (b > 0.0) c = fmod(a, b), a = b, b = c; 
  return a;
}")
(%definition "extern double flround(double x);")
(%localdef "double flround(double x) {
  double f = floor(x), c = ceil(x), d = x-f, u = c-x; 
  if (d == u) return fmod(f, 2.0) == 0.0 ? f : c;
  else return (d < u) ? f : c;
}")
(%definition "extern int strtofxfl(char *s, int radix, long *pl, double *pd);")
(%localdef "int strtofxfl(char *s, int radix, long *pl, double *pd) {
  extern int strcmp_ci(char *s1, char *s2); /* defined below */
  char *e; int conv = 0, eno = errno; long l; double d;
  for (; s[0] == '#'; s += 2) {
    switch (s[1]) {
      case 'b': case 'B': radix = 2; break;
      case 'o': case 'O': radix = 8; break;
      case 'd': case 'D': radix = 10; break;
      case 'x': case 'X': radix = 16; break;
      case 'e': case 'E': conv = 'e'; break;
      case 'i': case 'I': conv = 'i'; break;
      default: return 0;
    }
  }
  if (isspace(*s)) return 0;
  for (e = s; *e; ++e) { if (strchr(\".eEiInN\", *e)) break; }
  if (!*e || radix != 10) { /* s is not a syntax for an inexact number */
    l = (errno = 0, strtol(s, &e, radix));
    if (errno || *e || e == s) { if (conv == 'i') goto fl; return (errno = eno, 0); }
    if (conv == 'i') return (errno = eno, *pd = (double)l, 'i');
    if (FIXNUM_MIN <= l && l <= FIXNUM_MAX) return (errno = eno, *pl = l, 'e');
    return (errno = eno, 0); /* can't represent as an exact */
  } 
  fl: if (radix != 10) return (errno = eno, 0); 
  e = \"\", errno = 0; if (*s != '+' && *s != '-') d = strtod(s, &e);
  else if (strcmp_ci(s+1, \"inf.0\") == 0) d = (*s == '-' ? -HUGE_VAL : HUGE_VAL); 
  else if (strcmp_ci(s+1, \"nan.0\") == 0) d = HUGE_VAL - HUGE_VAL;
  else d = strtod(s, &e);
  if (errno || *e || e == s) return (errno = eno, 0);
  if ((conv == 'e') && ((l=(long)d) < FIXNUM_MIN || l > FIXNUM_MAX || (double)l != d))
    return (errno = eno, 0); /* can't be converted to an exact number */
  return (errno = eno, (conv == 'e') ? (*pl = fxflo(d), 'e') : (*pd = d, 'i'));
}")


; fixnums

; fixnums are tag-less immediates with 30 bits of payload

(%definition "/* fixnums */")
(%definition "typedef long fixnum_t;")
(%definition "#define is_fixnum_obj(o) (isim0(o))")
(%definition "#define is_fixnum_fixnum(i) ((void)(i), 1)")
(%definition "#define is_bool_fixnum(i) ((void)(i), 0)")
(%definition "#define is_fixnum_bool(i) ((void)(i), 0)")
(%definition "#define fixnum_from_obj(o) (getim0s(o))")
(%definition "#define fixnum_from_fixnum(i) (i)")
(%definition "#define fixnum_from_flonum(l,x) ((fixnum_t)(x))")
(%definition "#define bool_from_fixnum(i) ((void)(i), 1)")
(%definition "#define void_from_fixnum(i) (void)(i)")
(%definition "#define obj_from_fixnum(i) mkim0((fixnum_t)(i))")


; flonums

(%include <math.h>)
(%include <errno.h>)

(%definition "/* flonums */")
(%definition "#ifndef FLONUMS_BOXED")
(%definition "typedef double flonum_t;")
(%definition "#define is_flonum_obj(o) (((o) & 0xffff000000000000ULL) != 0ULL)")
(%definition "#define is_flonum_flonum(f) ((void)(f), 1)")
(%definition "#define is_flonum_bool(f) ((void)(f), 0)")
(%definition "#define is_bool_flonum(f) ((void)(f), 0)")
(%definition "#define is_fixnum_flonum(i) ((void)(i), 0)")
(%definition "#define is_flonum_fixnum(i) ((void)(i), 0)")
(%definition "#define flonum_from_flonum(l, f) (f)")
(%definition "#define flonum_from_fixnum(x) ((flonum_t)(x))")
(%definition "#define bool_from_flonum(f) ((void)(f), 0)")
(%definition "#define void_from_flonum(l, f) (void)(f)")
(%definition "union iod { cxoint_t i; double d; };")
(%definition "static double flonum_from_obj(obj o) { 
  union iod u; 
  assert(is_flonum_obj(o));
  u.i = ~o; 
  return u.d; 
}")
(%definition "static obj obj_from_flonum(int rc, double d) { 
  union iod u; 
  u.d = d; 
  assert(is_flonum_obj(~u.i));
  return ~u.i; 
}")
(%definition "#else /* FLONUMS_BOXED */")
(%localdef "static cxtype_t cxt_flonum = { \"flonum\", free };")
(%localdef "cxtype_t *FLONUM_NTAG = &cxt_flonum;")
(%definition "extern cxtype_t *FLONUM_NTAG;")
(%definition "typedef double flonum_t;")
(%definition "#define is_flonum_obj(o) (isnative(o, FLONUM_NTAG))")
(%definition "#define is_flonum_flonum(f) ((void)(f), 1)")
(%definition "#define is_flonum_bool(f) ((void)(f), 0)")
(%definition "#define is_bool_flonum(f) ((void)(f), 0)")
(%definition "#define is_fixnum_flonum(i) ((void)(i), 0)")
(%definition "#define is_flonum_fixnum(i) ((void)(i), 0)")
(%definition "#define flonum_from_obj(o) (*(flonum_t*)getnative(o, FLONUM_NTAG))")
(%definition "#define flonum_from_flonum(l, f) (f)")
(%definition "#define flonum_from_fixnum(x) ((flonum_t)(x))")
(%definition "#define bool_from_flonum(f) ((void)(f), 0)")
(%definition "#define void_from_flonum(l, f) (void)(f)")
(%definition "#define obj_from_flonum(l, f) hpushptr(dupflonum(f), FLONUM_NTAG, l)")
(%definition "extern flonum_t *dupflonum(flonum_t f);")
(%localdef "flonum_t *dupflonum(flonum_t f) {
  flonum_t *pf = cxm_cknull(malloc(sizeof(flonum_t)), \"malloc(flonum)\");
  *pf = f; return pf;
}")
(%definition "#endif")


; characters

(%include <ctype.h>)

; characters are 24-bit immediates with immediate tag 2

(%definition "/* characters */")
(%definition "#define CHAR_ITAG 2")  
(%definition "typedef int char_t;")
(%definition "#define ischar(o) (isimm(o, CHAR_ITAG))")
(%definition "#define is_char_obj(o) (isimm(o, CHAR_ITAG))")
(%definition "#define is_char_char(i) ((void)(i), 1)")
(%definition "#define is_char_bool(i) ((void)(i), 0)")
(%definition "#define is_bool_char(i) ((void)(i), 0)")
(%definition "#define is_char_fixnum(i) ((void)(i), 0)")
(%definition "#define is_fixnum_char(i) ((void)(i), 0)")
(%definition "#define is_char_flonum(i) ((void)(i), 0)")
(%definition "#define is_flonum_char(i) ((void)(i), 0)")
(%definition "#define char_from_obj(o) ((int)getimmu(o, CHAR_ITAG))")
(%definition "#define char_from_char(i) (i)")
(%definition "#define bool_from_char(i) ((void)(i), 1)")
(%definition "#define void_from_char(i) (void)(i)")
(%definition "#define obj_from_char(i) mkimm(i, CHAR_ITAG)")


; strings

(%include <string.h>)

(%definition "/* strings */")
(%localdef "static cxtype_t cxt_string = { \"string\", free };")
(%localdef "cxtype_t *STRING_NTAG = &cxt_string;")
(%definition "extern cxtype_t *STRING_NTAG;")
(%definition "#define isstring(o) (isnative(o, STRING_NTAG))")
(%definition "#define stringdata(o) ((int*)getnative(o, STRING_NTAG))")
(%definition "#define sdatachars(d) ((char*)((d)+1))")
(%definition "#define stringlen(o) (*stringdata(o))")
(%definition "#define stringchars(o) ((char*)(stringdata(o)+1))")
(%definition "#define hpushstr(l, s) hpushptr(s, STRING_NTAG, l)")

(%localdef "char* stringref(obj o, int i) {
  int *d = stringdata(o); assert(i >= 0 && i < *d);  
  return sdatachars(d)+i;
}")

(%definition "#ifdef NDEBUG
  #define stringref(o, i) (stringchars(o)+(i))
#else
  extern char* stringref(obj o, int i);
#endif")

(%definition "extern int *newstring(char *s);")
(%localdef "int *newstring(char *s) {
  int l, *d; assert(s); l = (int)strlen(s); 
  d = cxm_cknull(malloc(sizeof(int)+l+1), \"malloc(string)\");
  *d = l; strcpy(sdatachars(d), s); return d;
}")

(%definition "extern int *newstringn(char *s, int n);")
(%localdef "int *newstringn(char *s, int n) {
  int *d; char *ns; assert(s); assert(n >= 0);
  d = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(stringn)\");
  *d = n; memcpy((ns = sdatachars(d)), s, n); ns[n] = 0; return d;
}")

(%definition "extern int *allocstring(int n, int c);")
(%localdef "int *allocstring(int n, int c) {
  int *d; char *s; assert(n+1 > 0); 
  d = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
  *d = n; s = sdatachars(d); memset(s, c, n); s[n] = 0;
  return d;
}")

(%definition "extern int *substring(int *d, int from, int to);")
(%localdef "int *substring(int *d0, int from, int to) {
  int n = to-from, *d1; char *s0, *s1; assert(d0);
  assert(0 <= from && from <= to && to <= *d0); 
  d1 = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
  *d1 = n; s0 = sdatachars(d0); s1 = sdatachars(d1); 
  memcpy(s1, s0+from, n); s1[n] = 0;
  return d1;
}")

(%definition "extern int *stringcat(int *d0, int *d1);")
(%localdef "int *stringcat(int *d0, int *d1) {
  int l0 = *d0, l1 = *d1, n = l0+l1; char *s0, *s1, *s;
  int *d = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
  *d = n; s = sdatachars(d); s0 = sdatachars(d0); s1 = sdatachars(d1);
  memcpy(s, s0, l0); memcpy(s+l0, s1, l1); s[n] = 0;
  return d;
}")

(%definition "extern int *dupstring(int *d);")
(%localdef "int *dupstring(int *d0) {
  int n = *d0, *d1 = cxm_cknull(malloc(sizeof(int)+n+1), \"malloc(string)\");
  memcpy(d1, d0, sizeof(int)+n+1);
  return d1;
}")

(%definition "extern void stringfill(int *d, int c);")
(%localdef "void stringfill(int *d, int c) {
  int l = *d, i; char *s = sdatachars(d);
  for (i = 0; i < l; ++i) s[i] = c;
}")

(%definition "extern int strcmp_ci(char *s1, char *s2);")
(%localdef "int strcmp_ci(char *s1, char *s2) {
  int c1, c2, d;
  do { c1 = *s1++; c2 = *s2++; d = (unsigned)tolower(c1) - (unsigned)tolower(c2); } while (!d && c1 && c2);
  return d;
}")


; vectors

(%definition "/* vectors */")
(%definition "#define VECTOR_BTAG 1")  
(%definition "#define isvector(o) istagged(o, VECTOR_BTAG)")  
(%definition "#define vectorref(v, i) *taggedref(v, VECTOR_BTAG, i)")  
(%definition "#define vectorlen(v) taggedlen(v, VECTOR_BTAG)")  


; bytevectors

(%definition "/* bytevectors */")
(%localdef "static cxtype_t cxt_bytevector = { \"bytevector\", free };")
(%localdef "cxtype_t *BYTEVECTOR_NTAG = &cxt_bytevector;")
(%definition "extern cxtype_t *BYTEVECTOR_NTAG;")
(%definition "#define isbytevector(o) (isnative(o, BYTEVECTOR_NTAG))")
(%definition "#define bytevectordata(o) ((int*)getnative(o, BYTEVECTOR_NTAG))")
(%definition "#define bvdatabytes(d) ((unsigned char*)((d)+1))")
(%definition "#define bytevectorlen(o) (*bytevectordata(o))")
(%definition "#define bytevectorbytes(o) (bvdatabytes(bytevectordata(o)))")
(%definition "#define hpushu8v(l, s) hpushptr(s, BYTEVECTOR_NTAG, l)")
(%localdef "#define mallocbvdata(n) cxm_cknull(malloc(sizeof(int)+(n)), \"malloc(bytevector)\")")

(%definition "static int is_byte_obj(obj o) { return (obj_from_fixnum(0) <= o && o <= obj_from_fixnum(255)); } ")
(%definition "#define byte_from_obj(o) byte_from_fixnum(fixnum_from_obj(o))")
(%definition "#ifdef NDEBUG
  #define byte_from_fixnum(n) ((unsigned char)(n))
#else
  static unsigned char byte_from_fixnum(int n) { assert(0 <= n && n <= 255); return n; } 
#endif")
(%definition "#define byte_from_obj(o) byte_from_fixnum(fixnum_from_obj(o))")

(%localdef "unsigned char* bytevectorref(obj o, int i) {
  int *d = bytevectordata(o); assert(i >= 0 && i < *d); return (bvdatabytes(d))+i;
}")
(%definition "#ifdef NDEBUG
  #define bytevectorref(o, i) (bytevectorbytes(o)+(i))
#else
  extern unsigned char* bytevectorref(obj o, int i);
#endif")

(%definition "extern int *newbytevector(unsigned char *s, int n);")
(%localdef "int *newbytevector(unsigned char *s, int n) {
  int *d; assert(s); assert(n >= 0); 
  d = mallocbvdata(n); *d = n; memcpy(bvdatabytes(d), s, n); return d;
}")

(%definition "extern int *makebytevector(int n, int c);")
(%localdef "int *makebytevector(int n, int c) {
  int *d; assert(n >= 0); 
  d = mallocbvdata(n); *d = n; memset(bvdatabytes(d), c, n);
  return d;
}")

(%definition "extern int *allocbytevector(int n);")
(%localdef "int *allocbytevector(int n) {
  int *d = mallocbvdata(n); *d = n; return d;
}")

(%definition "extern int *dupbytevector(int *d);")
(%localdef "int *dupbytevector(int *d0) {
  int *d1 = mallocbvdata(*d0); *d1 = *d0; 
  memcpy(bvdatabytes(d1), bvdatabytes(d0), *d0); 
  return d1;
}")

(%definition "extern int bytevectoreq(int *d0, int *d1);")
(%localdef "int bytevectoreq(int *d0, int *d1) {
  int l0 = *d0, l1 = *d1;
  return (l0 != l1) ? 0 : memcmp(bvdatabytes(d0), bvdatabytes(d1), l0) == 0; 
}")

(%definition "extern int *subbytevector(int *d, int from, int to);")
(%localdef "int *subbytevector(int *d0, int from, int to) {
  int n = to-from, *d1; unsigned char *s0, *s1; assert(d0);
  assert(0 <= from && from <= to && to <= *d0); 
  d1 = mallocbvdata(n); *d1 = n; s0 = bvdatabytes(d0); s1 = bvdatabytes(d1); 
  memcpy(s1, s0+from, n); return d1;
}")


; boxes

(%definition "/* boxes */")
(%definition "#define BOX_BTAG 2")  
(%definition "#define isbox(o) istagged(o, BOX_BTAG)")  
(%definition "#define boxref(o) *taggedref(o, BOX_BTAG, 0)")  


; null

; () is immediate with payload 0 and immediate tag 3 (singular null object)

(%definition "/* null */")
(%definition "#define NULL_ITAG 3")  
(%definition "#define mknull() mkimm(0, NULL_ITAG)")  
(%definition "#define isnull(o) ((o) == mkimm(0, NULL_ITAG))")  


; pairs and lists

(%definition "/* pairs and lists */")
(%definition "#define PAIR_BTAG 3")  
(%definition "#define ispair(o) istagged(o, PAIR_BTAG)")  
(%definition "#define car(o) *taggedref(o, PAIR_BTAG, 0)")  
(%definition "#define cdr(o) *taggedref(o, PAIR_BTAG, 1)")  

(%definition "extern int islist(obj l);")
(%localdef "int islist(obj l) {
  obj s = l;
  for (;;) {
    if (isnull(l)) return 1;
    else if (!ispair(l)) return 0;
    else if ((l = cdr(l)) == s) return 0;
    else if (isnull(l)) return 1;
    else if (!ispair(l)) return 0;
    else if ((l = cdr(l)) == s) return 0;
    else s = cdr(s); 
  }
}")


; symbols

; symbols are 24-bit immediates with immediate tag 4

(%definition "/* symbols */")
(%definition "#define SYMBOL_ITAG 4")  
(%definition "#define issymbol(o) (isimm(o, SYMBOL_ITAG))")
(%definition "#define mksymbol(i) mkimm(i, SYMBOL_ITAG)")
(%definition "#define getsymbol(o) getimmu(o, SYMBOL_ITAG)")

(%localdef "static struct { char **a; char ***v; size_t sz; size_t u; size_t maxu; } symt;")
(%localdef "static unsigned long hashs(char *s) {
  unsigned long i = 0, l = (unsigned long)strlen(s), h = l;
  while (i < l) h = (h << 4) ^ (h >> 28) ^ s[i++];
  return h ^ (h  >> 10) ^ (h >> 20);
}")

(%definition "extern char *symbolname(int sym);")
(%localdef "char *symbolname(int sym) {
  assert(sym >= 0); assert(sym < (int)symt.u);
  return symt.a[sym];
}")

(%definition "extern int internsym(char *name);")
(%localdef "int internsym(char *name) {
  size_t i, j; /* based on a code (C) 1998, 1999 by James Clark. */
  if (symt.sz == 0) { /* init */
    symt.a = cxm_cknull(calloc(64, sizeof(char*)), \"symtab[0]\");
    symt.v = cxm_cknull(calloc(64, sizeof(char**)), \"symtab[1]\");
    symt.sz = 64, symt.maxu = 64 / 2;
    i = hashs(name) & (symt.sz-1);
  } else {
    unsigned long h = hashs(name);
    for (i = h & (symt.sz-1); symt.v[i]; i = (i-1) & (symt.sz-1))
      if (strcmp(name, *symt.v[i]) == 0) return (int)(symt.v[i] - symt.a);
    if (symt.u == symt.maxu) { /* rehash */
      size_t nsz = symt.sz * 2;
      char **na = cxm_cknull(calloc(nsz, sizeof(char*)), \"symtab[2]\");
      char ***nv = cxm_cknull(calloc(nsz, sizeof(char**)), \"symtab[3]\");
      for (i = 0; i < symt.sz; i++)
        if (symt.v[i]) {
          for (j = hashs(*symt.v[i]) & (nsz-1); nv[j]; j = (j-1) & (nsz-1)) ;
          nv[j] = symt.v[i] - symt.a + na;
        }
      free(symt.v); symt.v = nv; symt.sz = nsz; symt.maxu = nsz / 2;
      memcpy(na, symt.a, symt.u * sizeof(char*)); free(symt.a); symt.a = na; 
      for (i = h & (symt.sz-1); symt.v[i]; i = (i-1) & (symt.sz-1)) ;
    }
  }
  *(symt.v[i] = symt.a + symt.u) = 
    strcpy(cxm_cknull(malloc(strlen(name)+1), \"symtab[4]\"), name);
  return (int)((symt.u)++);
}")


; records

; records are typed blocks with rtd (non-immediate object) as type

(%definition "/* records */")
(%definition "#define isrecord(o) istyped(o)")  
(%definition "#define recordrtd(r) *typedtype(r)")  
(%definition "#define recordlen(r) typedlen(r)")  
(%definition "#define recordref(r, i) *typedref(r, i)")  


; control

; closure procedures are heap blocks of length >= 1 which
; have a pointer to the static code entry as 0th element;
; sfc allocates env-less global procedures in static memory,
; so procedure? answers #t to any nonzero out-of-heap pointer

(%localdef "int isprocedure(obj o) {
  if (!o) return 0;
  else if (isaptr(o) && !isobjptr(o)) return 1;
  else if (!isobjptr(o)) return 0;
  else { obj h = objptr_from_obj(o)[-1];
    return notaptr(h) && size_from_obj(h) >= 1 
      && isaptr(hblkref(o, 0)); }
}")

(%localdef "int procedurelen(obj o) {
  assert(isprocedure(o));
  return isobjptr(o) ? hblklen(o) : 1;
}")

(%localdef "obj* procedureref(obj o, int i) {
  int len; assert(isprocedure(o));
  len = isobjptr(o) ? hblklen(o) : 1;
  assert(i >= 0 && i < len);
  return &hblkref(o, i);   
}")

(%definition "/* procedures */")
(%definition "extern int isprocedure(obj o);")
(%definition "extern int procedurelen(obj o);")
(%definition "extern obj* procedureref(obj o, int i);")


; eof

; eof is tagged immediate with payload 0 and immediate tag 7 

(%definition "/* eof */")
(%definition "#define EOF_ITAG 7")  
(%definition "#define mkeof() mkimm(0, EOF_ITAG)")  
(%definition "#define iseof(o) ((o) == mkimm(0, EOF_ITAG))")  


; shebangs

; shebangs are symbol-like immediates with immediate tag 8

(%definition "/* shebangs (#! directives or script start lines) */")
(%definition "#define SHEBANG_ITAG 8")
(%definition "#define isshebang(o) (isimm(o, SHEBANG_ITAG))")
(%definition "#define mkshebang(i) mkimm(i, SHEBANG_ITAG)")
(%definition "#define getshebang(o) getimmu(o, SHEBANG_ITAG)")


; i/o ports

(%definition "/* input/output ports */")
(%definition "typedef struct { /* extends cxtype_t */
  const char *tname;
  void (*free)(void*);
  enum { SPT_CLOSED = 0, SPT_INPUT = 1, SPT_OUTPUT = 2, SPT_IO = 3 } spt;
  int  (*close)(void*);
  int  (*getch)(void*);
  int  (*ungetch)(int, void*);
  int  (*putch)(int, void*);
  int  (*flush)(void*);
  int  (*ctl)(const char*, void*, ...);
} cxtype_port_t, cxtype_iport_t, cxtype_oport_t;")
(%localdef "/* shared generic methods */")
(%localdef "static void nofree(void *p) {}")
(%localdef "static int noclose(void *p) { return 0; }")
(%localdef "static int nogetch(void *p) { return EOF; }")
(%localdef "static int noungetch(int c) { return c; }")
(%localdef "static int noputch(int c, void *p) { return EOF; }")
(%localdef "static int noflush(void *p) { return EOF; }")
(%localdef "static int noctl(const char *cmd, void *p, ...) { return -1; }")

; input ports

(%definition "/* input ports */")
(%definition "extern cxtype_t *IPORT_CLOSED_NTAG;")
(%definition "extern cxtype_t *IPORT_FILE_NTAG;")
(%definition "extern cxtype_t *IPORT_STRING_NTAG;")
(%definition "extern cxtype_t *IPORT_BYTEVECTOR_NTAG;")
(%definition "static cxtype_iport_t *iportvt(obj o) { 
  cxtype_t *pt; if (!isobjptr(o)) return NULL;
  pt = (cxtype_t*)objptr_from_obj(o)[-1];
  if (pt != IPORT_CLOSED_NTAG && pt != IPORT_FILE_NTAG &&
      pt != IPORT_STRING_NTAG && pt != IPORT_BYTEVECTOR_NTAG) return NULL; 
  else return (cxtype_iport_t*)pt; }")
(%definition "#define ckiportvt(o) ((cxtype_iport_t*)cxm_cknull(iportvt(o), \"iportvt\"))")  
(%definition "#define isiport(o) (iportvt(o) != NULL)")
(%definition "#define iportdata(o) ((void*)(*objptr_from_obj(o)))")

(%definition "static int iportgetc(obj o) {
  cxtype_iport_t *vt = iportvt(o); void *pp = iportdata(o);
  assert(vt); return vt->getch(pp);
}")
(%definition "static int iportpeekc(obj o) {
  cxtype_iport_t *vt = iportvt(o); void *pp = iportdata(o); int c;
  assert(vt); c = vt->getch(pp); if (c != EOF) vt->ungetch(c, pp); return c;
}")

; file input ports

(%definition "/* file input ports */")
(%localdef "static void ffree(void *vp) {
  /* FILE *fp = vp; assert(fp); cannot fclose(fp) here because of FILE reuse! */ }")
(%definition "#define mkiport_file(l, fp) hpushptr(fp, IPORT_FILE_NTAG, l)")

; string input ports 

(%definition "/* string input ports */")
(%definition "typedef struct { char *p; void *base; } sifile_t;")
(%localdef "sifile_t *sialloc(char *p, void *base) { 
  sifile_t *fp = cxm_cknull(malloc(sizeof(sifile_t)), \"malloc(sifile)\");
  fp->p = p; fp->base = base; return fp; }")
(%definition "extern sifile_t *sialloc(char *p, void *base);")
(%localdef "static void sifree(sifile_t *fp) { 
  assert(fp); if (fp->base) free(fp->base); free(fp); }")
(%localdef "static int siclose(sifile_t *fp) { 
  assert(fp); if (fp->base) free(fp->base); fp->base = NULL; fp->p = \"\"; return 0; }")
(%localdef "static int sigetch(sifile_t *fp) {
  int c; assert(fp && fp->p); if (!(c = *(fp->p))) return EOF; ++(fp->p); return c; }")
(%localdef "static int siungetch(int c, sifile_t *fp) {
  assert(fp && fp->p); --(fp->p); assert(c == *(fp->p)); return c; }")
(%definition "#define mkiport_string(l, fp) hpushptr(fp, IPORT_STRING_NTAG, l)")

; bytevector input ports 

(%definition "/* bytevector input ports */")
(%definition "typedef struct { unsigned char *p, *e; void *base; } bvifile_t;")
(%localdef "bvifile_t *bvialloc(unsigned char *p, unsigned char *e, void *base) { 
  bvifile_t *fp = cxm_cknull(malloc(sizeof(bvifile_t)), \"malloc(bvifile)\");
  fp->p = p; fp->e = e; fp->base = base; return fp; }")
(%definition "extern bvifile_t *bvialloc(unsigned char *p, unsigned char *e, void *base);")
(%localdef "static void bvifree(bvifile_t *fp) { 
  assert(fp); if (fp->base) free(fp->base); free(fp); }")
(%localdef "static int bviclose(bvifile_t *fp) { 
  assert(fp); if (fp->base) free(fp->base); fp->base = NULL; 
  fp->p = fp->e = (unsigned char *)\"\"; return 0; }")
(%localdef "static int bvigetch(bvifile_t *fp) {
  assert(fp && fp->p && fp->e); return (fp->p >= fp->e) ? EOF : (0xff & *(fp->p)++); }")
(%localdef "static int bviungetch(int c, bvifile_t *fp) {
  assert(fp && fp->p && fp->e); --(fp->p); assert(c == *(fp->p)); return c; }")
(%definition "#define mkiport_bytevector(l, fp) hpushptr(fp, IPORT_BYTEVECTOR_NTAG, l)")

; generic output ports

(%definition "/* output ports */")
(%definition "extern cxtype_t *OPORT_CLOSED_NTAG;")
(%definition "extern cxtype_t *OPORT_FILE_NTAG;")
(%definition "extern cxtype_t *OPORT_STRING_NTAG;")
(%definition "extern cxtype_t *OPORT_BYTEVECTOR_NTAG;")
(%definition "static cxtype_oport_t *oportvt(obj o) { 
  cxtype_t *pt; if (!isobjptr(o)) return NULL;
  pt = (cxtype_t*)objptr_from_obj(o)[-1];
  if (pt != OPORT_CLOSED_NTAG && pt != OPORT_FILE_NTAG && 
      pt != OPORT_STRING_NTAG && pt != OPORT_BYTEVECTOR_NTAG) return NULL; 
  else return (cxtype_oport_t*)pt; }")
(%definition "#define ckoportvt(o) ((cxtype_oport_t*)cxm_cknull(oportvt(o), \"oportvt\"))")  
(%definition "#define isoport(o) (oportvt(o) != NULL)")
(%definition "#define oportdata(o) ((void*)(*objptr_from_obj(o)))")

(%definition "static void oportputc(int c, obj o) {
  cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
  assert(vt); vt->putch(c, pp);
}")
(%definition "static void oportputs(char *s, obj o) {
  cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
  assert(vt); while (*s) vt->putch(*s++, pp);
}")
(%definition "static void oportwrite(char *s, int n, obj o) {
  cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
  assert(vt); while (n-- > 0) vt->putch(*s++, pp);
}")
(%definition "static void oportflush(obj o) {
  cxtype_oport_t *vt = oportvt(o); void *pp = oportdata(o);
  assert(vt); vt->flush(pp);
}")

(%definition "/* file output ports */")
(%definition "#define mkoport_file(l, fp) hpushptr(fp, OPORT_FILE_NTAG, l)")

; string output ports 

(%definition "/* string output ports */")
(%definition "typedef struct cbuf_tag { char *buf; char *fill; char *end; } cbuf_t;")
(%definition "extern cbuf_t* newcb(void);") 
(%localdef "cbuf_t* newcb(void) {
  cbuf_t* pcb = cxm_cknull(malloc(sizeof(cbuf_t)), \"malloc(cbuf)\");
  pcb->fill = pcb->buf = cxm_cknull(malloc(64), \"malloc(cbdata)\");
  pcb->end = pcb->buf + 64; return pcb;
}")
(%definition "extern void freecb(cbuf_t* pcb);") 
(%localdef "void freecb(cbuf_t* pcb) { if (pcb) { free(pcb->buf); free(pcb); } }")
(%localdef "static void cbgrow(cbuf_t* pcb, size_t n) {
  size_t oldsz = pcb->end - pcb->buf, newsz = oldsz*2;
  size_t cnt = pcb->fill - pcb->buf;
  if (oldsz + n > newsz) newsz += n;
  pcb->buf = cxm_cknull(realloc(pcb->buf, newsz), \"realloc(cbdata)\");
  pcb->fill = pcb->buf + cnt, pcb->end = pcb->buf + newsz;
}")
(%definition "extern int cbputc(int c, cbuf_t* pcb);") 
(%localdef "int cbputc(int c, cbuf_t* pcb) {
  if ((pcb)->fill == (pcb)->end) cbgrow(pcb, 1); *((pcb)->fill)++ = c; return c;
}")
(%localdef "static int cbflush(cbuf_t* pcb) { return 0; }")
(%localdef "static int cbclose(cbuf_t* pcb) { free(pcb->buf); pcb->buf = NULL; return 0; }")
(%definition "extern size_t cblen(cbuf_t* pcb);")
(%localdef "size_t cblen(cbuf_t* pcb) { return pcb->fill - pcb->buf; }")
(%definition "extern char* cbdata(cbuf_t* pcb);") 
(%localdef "char* cbdata(cbuf_t* pcb) {
  if (pcb->fill == pcb->end) cbgrow(pcb, 1); *(pcb->fill) = 0; return pcb->buf; 
}")
(%definition "#define mkoport_string(l, fp) hpushptr(fp, OPORT_STRING_NTAG, l)")

; bytevector output ports 

(%definition "/* bytevector output ports */")
(%definition "#define mkoport_bytevector(l, fp) hpushptr(fp, OPORT_BYTEVECTOR_NTAG, l)")

; port data, predicates and standard opening/closing convenience ops

(%localdef "/* port type array */")
(%localdef "#define PORTTYPES_MAX 8")
(%localdef "static cxtype_port_t cxt_port_types[PORTTYPES_MAX] = {
#define IPORT_CLOSED_PTINDEX     0
  { \"closed-input-port\", (void (*)(void*))nofree, 
    SPT_CLOSED, (int (*)(void*))noclose,
    (int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
    (int (*)(int, void*))noputch, (int (*)(void*))noflush, 
    (int (*)(const char *, void *, ...))noctl },
#define IPORT_FILE_PTINDEX       1
  { \"file-input-port\", ffree, 
    SPT_INPUT, (int (*)(void*))fclose, 
    (int (*)(void*))(fgetc), (int (*)(int, void*))(ungetc),
    (int (*)(int, void*))noputch, (int (*)(void*))noflush,
    (int (*)(const char *, void *, ...))noctl },
#define IPORT_STRING_PTINDEX     2
  { \"string-input-port\", (void (*)(void*))sifree, 
    SPT_INPUT, (int (*)(void*))siclose,
    (int (*)(void*))sigetch, (int (*)(int, void*))siungetch,
    (int (*)(int, void*))noputch, (int (*)(void*))noflush,
    (int (*)(const char *, void *, ...))noctl },
#define IPORT_BYTEVECTOR_PTINDEX 3
  { \"bytevector-input-port\", (void (*)(void*))bvifree, 
    SPT_INPUT, (int (*)(void*))bviclose,
    (int (*)(void*))bvigetch, (int (*)(int, void*))bviungetch,
    (int (*)(int, void*))noputch, (int (*)(void*))noflush,
    (int (*)(const char *, void *, ...))noctl },
#define OPORT_CLOSED_PTINDEX     4
  { \"closed-output-port\", (void (*)(void*))nofree, 
    SPT_OUTPUT, (int (*)(void*))noclose, 
    (int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
    (int (*)(int, void*))noputch, (int (*)(void*))noflush,
    (int (*)(const char *, void *, ...))noctl },
#define OPORT_FILE_PTINDEX       5
  { \"file-output-port\", ffree, 
    SPT_OUTPUT, (int (*)(void*))fclose, 
    (int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
    (int (*)(int, void*))(fputc), (int (*)(void*))fflush,
    (int (*)(const char *, void *, ...))noctl },
#define OPORT_STRING_PTINDEX     6
  { \"string-output-port\", (void (*)(void*))freecb, 
    SPT_OUTPUT, (int (*)(void*))cbclose,
    (int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
    (int (*)(int, void*))cbputc, (int (*)(void*))cbflush,
    (int (*)(const char *, void *, ...))noctl },
#define OPORT_BYTEVECTOR_PTINDEX 7
  { \"bytevector-output-port\", (void (*)(void*))freecb, 
    SPT_OUTPUT, (int (*)(void*))cbclose,
    (int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
    (int (*)(int, void*))cbputc, (int (*)(void*))cbflush,
    (int (*)(const char *, void *, ...))noctl }    
};")
(%localdef "cxtype_t *IPORT_CLOSED_NTAG = (cxtype_t *)&cxt_port_types[IPORT_CLOSED_PTINDEX];")
(%localdef "cxtype_t *IPORT_FILE_NTAG = (cxtype_t *)&cxt_port_types[IPORT_FILE_PTINDEX];")
(%localdef "cxtype_t *IPORT_STRING_NTAG = (cxtype_t *)&cxt_port_types[IPORT_STRING_PTINDEX];")
(%localdef "cxtype_t *IPORT_BYTEVECTOR_NTAG = (cxtype_t *)&cxt_port_types[IPORT_BYTEVECTOR_PTINDEX];")
(%localdef "cxtype_t *OPORT_CLOSED_NTAG = (cxtype_t *)&cxt_port_types[OPORT_CLOSED_PTINDEX];")
(%localdef "cxtype_t *OPORT_FILE_NTAG = (cxtype_t *)&cxt_port_types[OPORT_FILE_PTINDEX];")
(%localdef "cxtype_t *OPORT_STRING_NTAG = (cxtype_t *)&cxt_port_types[OPORT_STRING_PTINDEX];")
(%localdef "cxtype_t *OPORT_BYTEVECTOR_NTAG = (cxtype_t *)&cxt_port_types[OPORT_BYTEVECTOR_PTINDEX];")


; circularity and sharing helpers

(%localdef "/* eq hash table for circular/sharing checks and safe equal? */
typedef struct { obj *v; obj *r; size_t sz; size_t u, maxu, c; } stab_t;
static stab_t *staballoc(void) {
  stab_t *p = cxm_cknull(calloc(1, sizeof(stab_t)), \"newstab\");
  p->v = cxm_cknull(calloc(64, sizeof(obj)), \"newstab[1]\");
  p->sz = 64, p->maxu = 64 / 2; return p;
}
static stab_t *stabfree(stab_t *p) { 
  if (p) { free(p->v); free(p->r); free(p); }
  return NULL; 
}
static int stabnew(obj o, stab_t *p, int circ) {
  if (!o || notaptr(o) || notobjptr(o) || (circ && isaptr(objptr_from_obj(o)[-1]))) return 0;
  else if (circ && isaptr(objptr_from_obj(o)[0])) return 0; /* opaque */ 
  else { /* v[i] is 0 or heap obj, possibly with lower bit set if it's not new */
    unsigned long h = (unsigned long)o; size_t sz = p->sz, i, j;
    for (i = h & (sz-1); p->v[i]; i = (i-1) & (sz-1))
      if ((p->v[i] & ~1) == o) { p->v[i] |= 1; return 0; }
    if (p->u == p->maxu) { /* rehash */
      size_t nsz = sz * 2; obj *nv = cxm_cknull(calloc(nsz, sizeof(obj)), \"stabnew\");
      for (i = 0; i < sz; ++i) if (p->v[i] & ~1) {
        for (j = (unsigned long)(p->v[i] & ~1) & (nsz-1); nv[j]; j = (j-1) & (nsz-1)) ;
        nv[j] = p->v[i];
      }
      free(p->v); p->v = nv; sz = p->sz = nsz; p->maxu = nsz / 2;
      for (i = h & (sz-1); p->v[i]; i = (i-1) & (sz-1)) ;
    }
    p->v[i] = o; p->u += 1; return 1; 
  }
}
static void stabdelifu(obj o, stab_t *p) { 
  unsigned long h = (unsigned long)o; size_t sz = p->sz, i;
  for (i = h & (sz-1); p->v[i]; i = (i-1) & (sz-1)) if ((p->v[i] & ~1) == o) { 
    if (p->v[i] & 1) /* keep */; else p->v[i] = 1; /* del */
    return;
  }
}
static void stabpushp(obj o, stab_t *p) {
  obj *r = p->r; if (!r) { p->r = r = cxm_cknull(calloc(sizeof(obj), 12), \"stabpushp\"); r[1] = 10; }
  else if (r[0] == r[1]) { p->r = r = cxm_cknull(realloc(r, sizeof(obj)*(2+(size_t)r[1]*2)), \"stabpushp\"); r[1] *= 2; }
  r[2 + r[0]++] = o; 
}
static void stabpopp(stab_t *p) {
  obj *r = p->r; assert(r && r[0] > 0); r[0] -= 1;
}
static void stabcircular(obj o, stab_t *p) {
  tail: if (stabnew(o, p, 1)) {
    obj *op = objptr_from_obj(o), fo = op[-1];
    if (notaptr(fo)) { 
      obj *fop = op + size_from_obj(fo);
      stabpushp(0, p); while (op+1 < fop) stabcircular(*op++, p); stabpopp(p); 
      if (op+1 == fop) { stabpushp(o, p); o = *op; goto tail; }
    } 
  } else {
    obj *r = p->r; if (r) {
      obj *op = r+2, *fop = op+r[0];
      while (fop > op && fop[-1] != 0) stabdelifu(*--fop, p); 
      r[0] = fop - op;
    }
  }
}
static void stabshared(obj o, stab_t *p) {
  tail: if (stabnew(o, p, 0)) {
    obj *op = objptr_from_obj(o), fo = op[-1];
    if (notaptr(fo)) { 
      obj *fop = op + size_from_obj(fo); 
      while (op+1 < fop) stabshared(*op++, p);
      if (op+1 == fop) { o = *op; goto tail; }
    } 
  }
}
static stab_t *stabend(stab_t *p) {
  size_t nz, i, sz = p->sz;
  for (nz = i = 0; i < sz; ++i) if ((p->v[i] & ~1) && (p->v[i] & 1)) ++nz;
  if (nz) {
    size_t nsz, j; obj *nv; for (nsz = 8; nsz < nz*2; nsz *= 2) ;
    nv = cxm_cknull(calloc(nsz, sizeof(obj)), \"stabend\");
    for (i = 0; i < sz; ++i) if ((p->v[i] & ~1) && (p->v[i] & 1)) {
      for (j = (unsigned long)(p->v[i] & ~1) & (nsz-1); nv[j]; j = (j-1) & (nsz-1)) ;
      nv[j] = p->v[i];
    }
    free(p->v); p->v = nv; sz = p->sz = nsz; p->maxu = nsz / 2;
    free(p->r); p->r = NULL;
  } else p = stabfree(p);
  return p;
}
static long stabri(size_t i, stab_t *p, int upd) {
  obj *pri, ri; if (!p->r) p->r = cxm_cknull(calloc(p->sz, sizeof(obj)), \"stabri\");
  pri = p->r + i; ri = *pri; if (!ri) *pri = ri = ++(p->c);
  if (upd && ri > 0) *pri = -ri; return (long)ri;
}
static long stabref(obj o, stab_t *p, int upd) {
  if (!p || !o || notaptr(o) || notobjptr(o)) return 0; else {
    unsigned long h = (unsigned long)o; size_t sz = p->sz, i;
    for (i = h & (sz-1); p->v[i]; i = (i-1) & (sz-1))
      if ((p->v[i] & ~1) == o) return (p->v[i] & 1) ? stabri(i, p, upd) : 0; 
    return 0;
  }
}
static int stabufind(obj x, obj y, stab_t *p) {
  size_t sz = p->sz, i, ix=0, iy=0; /* bogus 0 inits to silence gcc */ obj *r = p->r;
  for (i = (unsigned long)x & (sz-1); p->v[i]; i = (i-1) & (sz-1)) if ((p->v[i] & ~1) == x) { ix = i; break; }
  for (i = ix; r[i] >= 0; ) i = (size_t)r[i]; if (i != ix) ix = (size_t)(r[ix] = i);  
  for (i = (unsigned long)y & (sz-1); p->v[i]; i = (i-1) & (sz-1)) if ((p->v[i] & ~1) == y) { iy = i; break; }
  for (i = iy; r[i] >= 0; ) i = (size_t)r[i]; if (i != iy) iy = (size_t)(r[iy] = i);
  if (ix == iy) return 1; /* same class, assumed to be equal */ 
  if (r[ix] < r[iy]) { r[ix] += r[iy]; r[iy] = ix; } else { r[iy] += r[ix]; r[ix] = iy; } return 0;
}
static int stabequal(obj x, obj y, stab_t *p) {
  obj h; int i, n; loop: if (x == y) return 1;
  if (!x || !y || notaptr(x) || notaptr(y) || notobjptr(x) || notobjptr(y)) return 0;
  if ((h = objptr_from_obj(x)[-1]) != objptr_from_obj(y)[-1]) return 0;
#ifdef FLONUMS_BOXED
  if (h == (obj)FLONUM_NTAG) return flonum_from_obj(x) == flonum_from_obj(y); 
#endif
  if (h == (obj)STRING_NTAG) return strcmp(stringchars(x), stringchars(y)) == 0;
  if (h == (obj)BYTEVECTOR_NTAG) return bytevectoreq(bytevectordata(x), bytevectordata(y)); 
  if (isaptr(h) || !(n = size_from_obj(h)) || hblkref(x, 0) != hblkref(y, 0)) return 0;
  if (stabufind(x, y, p)) return 1; /* seen before and decided to be equal */
  for (i = 1; i < n-1; ++i) if (!stabequal(hblkref(x, i), hblkref(y, i), p)) return 0;
  if (i == n-1) { x = hblkref(x, i); y = hblkref(y, i); goto loop; } else return 1; 
}
static int boundequal(obj x, obj y, int fuel) { /* => remaining fuel or <0 on failure */
  obj h; int i, n; loop: assert(fuel > 0); if (x == y) return fuel-1;
  if (!x || !y || notaptr(x) || notaptr(y) || notobjptr(x) || notobjptr(y)) return -1;
  if ((h = objptr_from_obj(x)[-1]) != objptr_from_obj(y)[-1]) return -1;
#ifdef FLONUMS_BOXED
  if (h == (obj)FLONUM_NTAG) return flonum_from_obj(x) == flonum_from_obj(y) ? fuel-1 : -1; 
#endif
  if (h == (obj)STRING_NTAG) return strcmp(stringchars(x), stringchars(y)) == 0 ? fuel-1 : -1;
  if (h == (obj)BYTEVECTOR_NTAG) return bytevectoreq(bytevectordata(x), bytevectordata(y)) ? fuel-1 : -1;
  if (isaptr(h) || !(n = size_from_obj(h)) || hblkref(x, 0) != hblkref(y, 0)) return -1;
  if (--fuel == 0) return 0; /* we must spend fuel while comparing objects themselves */
  for (i = 1; i < n-1; ++i) if ((fuel = boundequal(hblkref(x, i), hblkref(y, i), fuel)) <= 0) return fuel;
  if (i == n-1) { x = hblkref(x, i); y = hblkref(y, i); goto loop; } else return fuel;
}")


; circularity

(%definition "extern int iscircular(obj x);")
(%localdef "int iscircular(obj x) {
  if (!x || notaptr(x) || notobjptr(x)) return 0;
  else { stab_t *p = staballoc(); stabcircular(x, p); p = stabend(p); stabfree(p); return p != NULL; }
}")

; equivalence and case

(%definition "extern int iseqv(obj x, obj y);")
(%localdef "int iseqv(obj x, obj y) {
  obj h; if (x == y) return 1;
  if (!x || !y || notaptr(x) || notaptr(y) || notobjptr(x) || notobjptr(y)) return 0;
  if ((h = objptr_from_obj(x)[-1]) != objptr_from_obj(y)[-1]) return 0;
#ifdef FLONUMS_BOXED
  if (h == (obj)FLONUM_NTAG) return *(flonum_t*)objptr_from_obj(x)[0] == *(flonum_t*)objptr_from_obj(y)[0]; 
#endif
  return 0;
}")

(%definition "extern obj ismemv(obj x, obj l);")
(%localdef "obj ismemv(obj x, obj l) {
  if (!x || notaptr(x) || notobjptr(x)) {
    for (; l != mknull(); l = cdr(l)) 
      { if (car(l) == x) return l; }
  } else if (is_flonum_obj(x)) {
    flonum_t fx = flonum_from_obj(x); 
    for (; l != mknull(); l = cdr(l)) 
      { obj y = car(l); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return l; }
  } else { /* for others, memv == memq */
    for (; l != mknull(); l = cdr(l)) 
      { if (car(l) == x) return l; }
  } return 0;
}")

(%definition "extern obj isassv(obj x, obj l);")
(%localdef "obj isassv(obj x, obj l) {
  if (!x || notaptr(x) || notobjptr(x)) {
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l); if (car(p) == x) return p; }
  } else if (is_flonum_obj(x)) {
    flonum_t fx = flonum_from_obj(x); 
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l), y = car(p); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return p; }
  } else { /* for others, assv == assq */
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l); if (car(p) == x) return p; }
  } return 0;
}")

(%definition "extern int isequal(obj x, obj y);")
(%localdef "int isequal(obj x, obj y) {
  stab_t *p; obj *r; size_t i; int res = boundequal(x, y, 500);
  if (res != 0) return res > 0; /* small/non-circular/easy */
  p = staballoc(); stabshared(x, p); stabshared(y, p);
  r = p->r = cxm_cknull(calloc(p->sz, sizeof(obj)), \"isequal\");
  for (i = 0; i < p->sz; ++i) if (p->v[i] & ~1) r[i] = -1; 
  res = stabequal(x, y, p); stabfree(p); return res;
}")

(%definition "extern obj ismember(obj x, obj l);")
(%localdef "obj ismember(obj x, obj l) {
  if (!x || notaptr(x) || notobjptr(x)) {
    for (; l != mknull(); l = cdr(l)) 
      { if (car(l) == x) return l; }
  } else if (is_flonum_obj(x)) {
    flonum_t fx = flonum_from_obj(x); 
    for (; l != mknull(); l = cdr(l)) 
      { obj y = car(l); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return l; }
  } else if (isstring(x)) {
    char *xs = stringchars(x);
    for (; l != mknull(); l = cdr(l)) 
      { obj y = car(l); if (isstring(y) && 0 == strcmp(xs, stringchars(y))) return l; }
  } else {
    for (; l != mknull(); l = cdr(l)) 
      { if (isequal(car(l), x)) return l; }
  } return 0;
}")

(%definition "extern obj isassoc(obj x, obj l);")
(%localdef "obj isassoc(obj x, obj l) {
  if (!x || notaptr(x) || notobjptr(x)) {
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l); if (car(p) == x) return p; }
  } else if (is_flonum_obj(x)) {
    flonum_t fx = flonum_from_obj(x); 
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l), y = car(p); if (is_flonum_obj(y) && fx == flonum_from_obj(y)) return p; }
  } else if (isstring(x)) {
    char *xs = stringchars(x);
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l), y = car(p); if (isstring(y) && 0 == strcmp(xs, stringchars(y))) return p; }
  } else {
    for (; l != mknull(); l = cdr(l)) 
      { obj p = car(l); if (isequal(car(p), x)) return p; }
  } return 0;
}")

; S-expression writer

(%localdef "/* internal recursive write procedure */
typedef struct { stab_t *pst; int disp; cxtype_oport_t *vt; void *pp; } wenv_t;
static void wrc(int c, wenv_t *e) { e->vt->putch(c, e->pp); }
static void wrs(char *s, wenv_t *e) {
  cxtype_oport_t *vt = e->vt; void *pp = e->pp;
  assert(vt); while (*s) vt->putch(*s++, pp);
}
static int cleansymname(char *s) {
  char *inits = \"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?@^_~\";
  char *subss = \"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!$%&*/:<=>?@^_~0123456789.@+-\";
  if (s[0] == 0 || s[strspn(s, subss)] != 0) return 0; else if (strchr(inits, s[0])) return 1;
  else if (s[0] == '+' || s[0] == '-') return s[1] == 0 || (s[1] == '.' && s[2] && !isdigit(s[2])) || !isdigit(s[1]);
  else return s[0] == '.' && s[1] && !isdigit(s[1]); 
}
static void wrdatum(obj o, wenv_t *e) {
  long ref;
  tail: ref = stabref(o, e->pst, 1); /* update ref after access */
  if (ref < 0) { char buf[30]; sprintf(buf, \"#%ld#\", -ref-1); wrs(buf, e); return; }
  if (ref > 0) { char buf[30]; sprintf(buf, \"#%ld=\", +ref-1); wrs(buf, e); }
  if (is_bool_obj(o)) {
    wrs(bool_from_obj(o) ? \"#t\" : \"#f\", e);
  } else if (is_fixnum_obj(o)) {
    char buf[30]; sprintf(buf, \"%ld\", fixnum_from_obj(o)); wrs(buf, e);
  } else if (is_flonum_obj(o)) {
    char buf[30], *s; double d = flonum_from_obj(o); sprintf(buf, \"%.15g\", d);
    for (s = buf; *s != 0; s++) if (strchr(\".eE\", *s)) break;
    if (d != d) strcpy(buf, \"+nan.0\"); else if (d <= -HUGE_VAL) strcpy(buf, \"-inf.0\");
    else if (d >= HUGE_VAL) strcpy(buf, \"+inf.0\"); else if (*s == 'E') *s = 'e'; 
    else if (*s == 0) { *s++ = '.'; *s++ = '0'; *s = 0; }
    wrs(buf, e);
  } else if (iseof(o)) {
    wrs(\"#<eof>\", e);
  } else if (isvoid(o)) {
    wrs(\"#<void>\", e);
  } else if (isshebang(o)) {
    char *s = symbolname(getshebang(o));
    wrs(\"#<!\", e); wrs(s, e); wrc('>', e);
  } else if (o == obj_from_unit()) {
    wrs(\"#<values>\", e);
  } else if (isiport(o)) {
    char buf[60]; sprintf(buf, \"#<%s>\", ckiportvt(o)->tname); wrs(buf, e);
  } else if (isoport(o)) {
    char buf[60]; sprintf(buf, \"#<%s>\", ckoportvt(o)->tname); wrs(buf, e);
  } else if (issymbol(o)) {
    char *s = symbolname(getsymbol(o));
    if (e->disp || cleansymname(s)) wrs(s, e);
    else {
      wrc('|', e);
      while (*s) {
        int c = *s++;
        switch(c) {
          case '|': wrs(\"\\\\|\", e); break;
          case '\\\\': wrs(\"\\\\\\\\\", e); break;
          default: wrc(c, e); break;
        }
      }
      wrc('|', e);
    }

  } else if (isnull(o)) {
    wrs(\"()\", e);
  } else if (ispair(o)) {
    wrc('(', e); wrdatum(car(o), e);
    while (ispair(cdr(o)) && !stabref(cdr(o), e->pst, 0)) { wrc(' ', e); o = cdr(o);  wrdatum(car(o), e); }
    if (!isnull(cdr(o))) { wrs(\" . \", e); wrdatum(cdr(o), e); }
    wrc(')', e);
  } else if (is_char_obj(o)) {
    int c = char_from_obj(o);
    if (e->disp) wrc(c, e);
    else switch(c) {
      case 0x00: wrs(\"#\\\\null\", e); break;
      case 0x07: wrs(\"#\\\\alarm\", e); break;
      case 0x08: wrs(\"#\\\\backspace\", e); break;
      case 0x7f: wrs(\"#\\\\delete\", e); break;
      case 0x1b: wrs(\"#\\\\escape\", e); break;
      case '\\t': wrs(\"#\\\\tab\", e); break;
      case '\\n': wrs(\"#\\\\newline\", e); break;
      case '\\r': wrs(\"#\\\\return\", e); break;
      case ' ': wrs(\"#\\\\space\", e); break;
      default: wrs(\"#\\\\\", e); wrc(c, e); break;
    }
  } else if (isstring(o)) {
    char *s = stringchars(o);
    if (e->disp) wrs(s, e);
    else {
      wrc('\\\"', e);
      while (*s) {
        int c = *s++;
        switch(c) {
          case '\\\"': wrs(\"\\\\\\\"\", e); break;
          case '\\\\': wrs(\"\\\\\\\\\", e); break;
          default: wrc(c, e); break;
        }
      }
      wrc('\\\"', e);
    }
  } else if (isvector(o)) {
    int i, n = vectorlen(o);
    wrs(\"#(\", e);
    for (i = 0; i < n; ++i) { 
      if (i) wrc(' ', e); wrdatum(vectorref(o, i), e); 
    }
    wrc(')', e);
  } else if (isbytevector(o)) {
    int i, n = bytevectorlen(o);
    wrs(\"#u8(\", e);
    for (i = 0; i < n; ++i) { 
      char buf[30]; sprintf(buf, \"%d\", *bytevectorref(o, i));
      if (i) wrc(' ', e); wrs(buf, e); 
    }
    wrc(')', e);
  } else if (isbox(o)) {
    wrs(\"#&\", e); o = boxref(o); goto tail;
  } else if (istagged(o, 0)) {
    int i, n = taggedlen(o, 0);
    wrs(\"#<values\", e);
    for (i = 0; i < n; ++i) { 
      wrc(' ', e); wrdatum(*taggedref(o, 0, i), e); 
    }
    wrc('>', e);
  } else if (isprocedure(o)) {
    char buf[60];
    if (isobjptr(hblkref(o, 0))) sprintf(buf, \"#<vmclosure @%p>\", objptr_from_obj(o));
    else sprintf(buf, \"#<procedure @%p>\", objptr_from_obj(o)); 
    wrs(buf, e);
  } else if (isrecord(o)) {
    int i, n = recordlen(o);
    wrs(\"#<record \", e);
    wrdatum(recordrtd(o), e); // TODO: no need to show as shared!
    for (i = 0; i < n; ++i) { 
      wrc(' ', e); wrdatum(recordref(o, i), e); 
    }
    wrc('>', e);
  } else {
    wrs(\"#<unknown>\", e);
  }
}")

(%definition "/* S-expression writers */
extern void oportputsimple(obj x, obj p, int disp);
extern void oportputcircular(obj x, obj p, int disp);
extern void oportputshared(obj x, obj p, int disp);")

(%localdef "/* S-expression writers */
void oportputsimple(obj x, obj p, int disp) {
  wenv_t e; e.pst = NULL; e.disp = disp; e.vt = oportvt(p); e.pp = oportdata(p);
  wrdatum(x, &e);
}
void oportputcircular(obj x, obj p, int disp) {
  wenv_t e; e.pst = staballoc(); e.disp = disp; e.vt = oportvt(p); e.pp = oportdata(p);
  stabcircular(x, e.pst); e.pst = stabend(e.pst);
  wrdatum(x, &e);
  stabfree(e.pst);
}
void oportputshared(obj x, obj p, int disp) {
  wenv_t e; e.pst = staballoc(); e.disp = disp; e.vt = oportvt(p); e.pp = oportdata(p);
  stabshared(x, e.pst); e.pst = stabend(e.pst);
  wrdatum(x, &e);
  stabfree(e.pst);
}")


; time

(%include <time.h>)