Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-12-25 21:58:54 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions
skint/pre/n.sf
ESL 74d652f3d9 n.sf fixes
2024-08-29 18:08:59 -04:00

2055 lines
75 KiB
Text
Raw Permalink Blame History

;------------------------------------------------------------------------------
;
; C extracts from Large RNRS compatibility library for #F, fixnum/flonums
;
;------------------------------------------------------------------------------
(%include "s.h")
;------------------------------------------------------------------------------
; 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")
(%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 "#ifndef NDEBUG
char* stringref(obj o, int i) {
int *d = stringdata(o); assert(i >= 0 && i < *d);
return sdatachars(d)+i;
}
#endif")
(%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 "#ifndef NDEBUG
unsigned char* bytevectorref(obj o, int i) {
int *d = bytevectordata(o); assert(i >= 0 && i < *d); return (bvdatabytes(d))+i;
}
#endif")
(%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 enum { CTLOP_RDLN } ctlop_t;")
(%definition "typedef struct { /* extends cxtype_t */
const char *tname;
void (*free)(void*);
enum { SPT_INPUT = 1, SPT_OUTPUT = 2, SPT_IO = 3, SPT_BINARY = 4 } spt;
int (*close)(void*);
int (*getch)(void*);
int (*ungetch)(int, void*);
int (*putch)(int, void*);
int (*flush)(void*);
int (*ctl)(ctlop_t, void*, ...);
} cxtype_port_t, cxtype_iport_t, cxtype_oport_t;")
(%definition "#define PORTTYPES_MAX 10")
(%definition "extern cxtype_port_t cxt_port_types[PORTTYPES_MAX];")
(%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(ctlop_t op, 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_BYTEFILE_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 >= (cxtype_t*)&cxt_port_types[0] &&
pt < (cxtype_t*)&cxt_port_types[PORTTYPES_MAX] &&
(((cxtype_port_t*)pt)->spt & SPT_INPUT))
return (cxtype_iport_t*)pt; else return NULL; }")
(%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 */")
(%definition "typedef struct tifile_tag tifile_t;")
(%definition "extern tifile_t *tialloc(FILE *fp);")
(%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; }")
(%localdef "static int sictl(ctlop_t op, sifile_t *fp, ...) {
if (op == CTLOP_RDLN) {
va_list args; int **pd; va_start(args, fp);
pd = va_arg(args, int **);
if (*(fp->p) == 0) *pd = NULL;
else {
char *s = strchr(fp->p, '\\n');
if (s) { *pd = newstringn(fp->p, s-fp->p); fp->p = s+1; }
else { *pd = newstring(fp->p); fp->p += strlen(fp->p); }
}
va_end(args);
return 0;
}
return -1;
}")
(%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_BYTEFILE_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 >= (cxtype_t*)&cxt_port_types[0] &&
pt < (cxtype_t*)&cxt_port_types[PORTTYPES_MAX] &&
(((cxtype_port_t*)pt)->spt & SPT_OUTPUT))
return (cxtype_oport_t*)pt; else return NULL; }")
(%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* cbinit(cbuf_t* pcb) {
pcb->fill = pcb->buf = cxm_cknull(malloc(64), \"malloc(cbdata)\");
pcb->end = pcb->buf + 64; return pcb;
}")
(%localdef "cbuf_t* newcb(void) {
cbuf_t* pcb = cxm_cknull(malloc(sizeof(cbuf_t)), \"malloc(cbuf)\");
return cbinit(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 char* cballoc(cbuf_t* pcb, size_t n);")
(%localdef "char* cballoc(cbuf_t* pcb, size_t n) {
assert(pcb); /* allow for extra 1 char after n */
if (pcb->fill + n+1 > pcb->end) cbgrow(pcb, n+1);
pcb->fill += n;
return pcb->fill - n;
}")
(%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 "extern cbuf_t* cbclear(cbuf_t *pcb);")
(%localdef "cbuf_t *cbclear(cbuf_t *pcb) { pcb->fill = pcb->buf; return pcb; }")
(%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)")
; text input port (uses cbuf)
(%localdef "typedef enum { TIF_NONE = 0, TIF_EOF = 1, TIF_CI = 2 } tiflags_t;
struct tifile_tag { cbuf_t cb; char *next; FILE *fp; int lno; tiflags_t flags; };
tifile_t *tialloc(FILE *fp) {
tifile_t *tp = cxm_cknull(malloc(sizeof(tifile_t)), \"malloc(tifile)\");
cbinit(&tp->cb); tp->next = tp->cb.buf; *(tp->next) = 0;
tp->fp = fp; tp->lno = 0; tp->flags = TIF_NONE;
return tp;
}
static void tifree(tifile_t *tp) {
assert(tp); cbclose(&tp->cb); ffree(tp->fp); free(tp); }
static int ticlose(tifile_t *tp) {
assert(tp); cbclose(&tp->cb); fclose(tp->fp); return 0; }
static int tigetch(tifile_t *tp) {
int c; retry: c = *(tp->next);
if (c != 0) { ++(tp->next); return c; }
/* see if we need to return actual 0 or refill the line */
if (tp->next < tp->cb.fill) { ++(tp->next); return c; }
else if (tp->flags & TIF_EOF || !tp->fp) return EOF;
else { /* refill with next line from fp */
cbuf_t *pcb = cbclear(&tp->cb); FILE *fp = tp->fp;
char *line = fgets(cballoc(pcb, 256), 256, fp);
if (!line) { cbclear(pcb); tp->flags |= TIF_EOF; }
else { /* manually add the rest of the line */
size_t len = strlen(line); pcb->fill = pcb->buf + len;
if (len > 0 && line[len-1] != '\\n') {
do { c = getc(fp); if (c == EOF) break; cbputc(c, pcb); } while (c != '\\n');
if (c == EOF) tp->flags |= TIF_EOF;
}
}
tp->lno += 1; tp->next = cbdata(pcb); /* 0-term */
goto retry;
}
}
static int tiungetch(int c, tifile_t *tp) {
assert(tp->next > tp->cb.buf && tp->next <= tp->cb.fill);
tp->next -= 1; // todo: utf-8
return c;
}
static int tictl(ctlop_t op, tifile_t *tp, ...) {
if (op == CTLOP_RDLN) {
va_list args; int c, n, **pd;
va_start(args, tp);
pd = va_arg(args, int **);
c = tigetch(tp);
if (c == EOF) {
*pd = NULL;
} else {
char *s; tiungetch(c, tp);
s = tp->next; n = tp->cb.fill - s;
if (n > 0 && s[n-1] == '\\n') --n;
*pd = newstringn(s, n);
tp->next = tp->cb.fill;
}
va_end(args);
return 0;
}
return -1;
}")
; port data, predicates and standard opening/closing convenience ops
(%localdef "/* port type array */")
(%localdef "cxtype_port_t cxt_port_types[PORTTYPES_MAX] = {
#define IPORT_CLOSED_PTINDEX 0
{ \"closed-input-port\", (void (*)(void*))nofree,
SPT_INPUT, (int (*)(void*))noclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(ctlop_t, void *, ...))noctl },
#define IPORT_FILE_PTINDEX 1
{ \"file-input-port\", (void (*)(void*))tifree,
SPT_INPUT, (int (*)(void*))ticlose,
(int (*)(void*))tigetch, (int (*)(int, void*))tiungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(ctlop_t, void *, ...))tictl },
#define IPORT_BYTEFILE_PTINDEX 2
{ \"binary-file-input-port\", ffree,
SPT_INPUT|SPT_BINARY, (int (*)(void*))fclose,
(int (*)(void*))(fgetc), (int (*)(int, void*))(ungetc),
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(ctlop_t, void *, ...))noctl },
#define IPORT_STRING_PTINDEX 3
{ \"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 (*)(ctlop_t, void *, ...))sictl },
#define IPORT_BYTEVECTOR_PTINDEX 4
{ \"bytevector-input-port\", (void (*)(void*))bvifree,
SPT_INPUT|SPT_BINARY, (int (*)(void*))bviclose,
(int (*)(void*))bvigetch, (int (*)(int, void*))bviungetch,
(int (*)(int, void*))noputch, (int (*)(void*))noflush,
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_CLOSED_PTINDEX 5
{ \"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 (*)(ctlop_t, void *, ...))noctl },
#define OPORT_FILE_PTINDEX 6
{ \"file-output-port\", ffree,
SPT_OUTPUT, (int (*)(void*))fclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))(fputc), (int (*)(void*))fflush,
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_BYTEFILE_PTINDEX 7
{ \"binary-file-output-port\", ffree,
SPT_OUTPUT|SPT_BINARY, (int (*)(void*))fclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))(fputc), (int (*)(void*))fflush,
(int (*)(ctlop_t, void *, ...))noctl },
#define OPORT_STRING_PTINDEX 8
{ \"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 (*)(ctlop_t, void *, ...))noctl },
#define OPORT_BYTEVECTOR_PTINDEX 9
{ \"bytevector-output-port\", (void (*)(void*))freecb,
SPT_OUTPUT|SPT_BINARY, (int (*)(void*))cbclose,
(int (*)(void*))nogetch, (int (*)(int, void*))noungetch,
(int (*)(int, void*))cbputc, (int (*)(void*))cbflush,
(int (*)(ctlop_t, 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_BYTEFILE_NTAG = (cxtype_t *)&cxt_port_types[IPORT_BYTEFILE_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_BYTEFILE_NTAG = (cxtype_t *)&cxt_port_types[OPORT_BYTEFILE_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) {
static char inisub_map[256] = { /* ini: [a-zA-Z!$%&*:/<=>?@^_~] sub: ini + [0123456789.@+-] */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 2, 0, 2, 2, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 1, 0, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
};
char *p = s; while (*p) if (inisub_map[*p++ & 0xFF] == 0) return 0; if (!s[0]) return 0;
if (inisub_map[s[0] & 0xFF] == 1) return 1;
if (s[0] == '+' || s[0] == '-') {
if (strcmp_ci(s+1, \"inf.0\") == 0 || strcmp_ci(s+1, \"nan.0\") == 0) return 0;
if ((s[1] == 'i' || s[1] == 'I') && s[2] == 0) return 0;
return s[1] == 0 || (s[1] == '.' && s[2] && !isdigit(s[2])) || (s[1] != '.' && !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];
sprintf(buf, \"#<procedure @%p>\", (void*)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);")
(%definition "/* S-expression tokenizer */
extern int slex(int (*in_getc)(void*), int (*in_ungetc)(int, void*), void *in, cbuf_t *pcb);")
(%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>)
; system-dependent extensions
(%localdef "/* system-dependent extensions */")
(%localdef "
extern int is_tty_port(obj o)
{
FILE *fp = NULL;
if ((cxtype_t*)iportvt(o) == IPORT_FILE_NTAG) fp = ((tifile_t*)iportdata(o))->fp;
else if ((cxtype_t*)oportvt(o) == OPORT_FILE_NTAG) fp = (FILE*)oportdata(o);
if (!fp) return 0;
return isatty(fileno(fp));
}
#ifdef WIN32
int dirsep = '\\\\';
int pathsep = ';';
#else
int dirsep = '/';
int pathsep = ':';
#endif
#ifdef LIBPATH
char *lib_path = ##LIBPATH;
#elif defined(WIN32)
char *lib_path = \".\\\\\";
#else
char *lib_path = \"./\";
#endif
extern char *argv_ref(int idx)
{
char **pv = cxg_argv;
/* be careful with indexing! */
if (idx < 0) return NULL;
while (idx-- > 0) if (*pv++ == NULL) return NULL;
return *pv;
}
#if defined(WIN32)
#define cxg_envv _environ
#elif defined(__linux)
#define cxg_envv environ
#elif defined(__APPLE__)
extern char **environ;
#define cxg_envv environ
#else /* add more systems? */
char **cxg_envv = { NULL };
#endif
extern char *envv_ref(int idx)
{
char **pv = cxg_envv;
/* be careful with indexing! */
if (idx < 0) return NULL;
while (idx-- > 0) if (*pv++ == NULL) return NULL;
return *pv;
}
extern char *get_cwd(void)
{
static char buf[FILENAME_MAX]; size_t len;
if (getcwd(buf, FILENAME_MAX) == NULL) return NULL;
len = strlen(buf);
/* if this is a regular path that has internal separators but not at the end, add it */
if (len > 0 && len < FILENAME_MAX-1 && strchr(buf, dirsep) && buf[len-1] != dirsep) {
buf[len++] = dirsep; buf[len] = 0;
}
return buf;
}
extern int set_cwd(char *cwd)
{
return chdir(cwd);
}
#define TT_FALSE 'f'
#define TT_TRUE 't'
#define TT_NUMBER 'n'
#define TT_CHAR 'c'
#define TT_STRING 's'
#define TT_SYMBOL 'y'
#define TT_OPENLIST 'l'
#define TT_OPENVEC 'v'
#define TT_OPENU8VEC 'u'
#define TT_CLOSE 'r'
#define TT_OPENLIST2 'b'
#define TT_CLOSE2 'k'
#define TT_QUOTE '\\''
#define TT_QQUOTE '`'
#define TT_UNQUOTE ','
#define TT_UNQSPL '@'
#define TT_DOT '.'
#define TT_BOX '&'
#define TT_HDEF '='
#define TT_HREF '#'
#define TT_HSEMI ';'
#define TT_SHEBANG '!'
#define TT_SHEBANG_FC 'F'
#define TT_SHEBANG_NF 'N'
#define TT_ERR 0
#define TT_EOF -1
#if 1
static char num_map[256] = { /* [#A-Za-z/0123456789.@+-] */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
};
#define is_num(c) (num_map[(c) & 0xFF]) /* NB: eof at num_map[255] */
#else
static int is_num(int c)
{ /* this covers all initials and constituents of prefixed numbers */
char *s = \"#ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz/0123456789+-.@\";
return c != EOF && strchr(s, c) != NULL;
}
#endif
#if 1
static char numsym_map[256] = { /* [A-Za-z!$%&*:/<=>?^_~0123456789.@+-] */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 1, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1,
0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
};
#define is_numsym(c) (numsym_map[(c) & 0xFF]) /* NB: eof at numsym_map[255] */
#else
static int is_numsym(int c)
{ /* this covers all initials and constituents of plain symbols and nonprefixed decimals */
char *s = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!$%&*/:<=>?^_~0123456789+-.@\";
return c != EOF && strchr(s, c) != NULL;
}
#endif
static int is_delimiter(int c)
{
switch (c) {
case '\\t': case '\\r': case '\\n': case ' ':
case '(': case ')': case '[': case ']':
case '|': case '\\\"': case ';': case EOF:
return 1;
}
return 0;
}
static int lex_1esc(int c)
{
switch (c) {
case 'a': return '\\a';
case 'b': return '\\b';
case 't': return '\\t';
case 'n': return '\\n';
case 'r': return '\\r';
case '|': return '|';
case '\\\"': return '\\\"';
case '\\\\': return '\\\\';
}
return EOF;
}
static int lex_xesc(int c, int xc)
{
if (c >= '0' && c <= '9') return (xc << 4) + c - '0';
if (c >= 'A' && c <= 'F') return (xc << 4) + 10 + c - 'A';
if (c >= 'a' && c <= 'f') return (xc << 4) + 10 + c - 'a';
return EOF;
}
/* slex: splits input into tokens delivered via char buf */
int slex(int (*in_getc)(void*), int (*in_ungetc)(int, void*), void *in, cbuf_t *pcb)
{
int c, xc;
next: cbclear(pcb);
switch (c = in_getc(in)) {
case EOF: return TT_EOF;
case ',': goto after_comma;
case '`': return TT_QQUOTE;
case '\\'': return TT_QUOTE;
case ']': return TT_CLOSE2;
case '[': return TT_OPENLIST2;
case ')': return TT_CLOSE;
case '(': return TT_OPENLIST;
case ';': goto in_linecomm;
case '|': goto in_barsym;
case '\\\"': goto in_string;
case '#': cbputc(c, pcb); goto after_hash;
case '.': cbputc(c, pcb); goto after_dot;
default:
if (is_numsym(c)) goto in_numsym;
if ((c >= '\\t' && c <= '\\n') || (c >= '\\f' && c <= '\\r') || c == ' ') goto in_whitespace;
in_ungetc(c, in); goto err;
}
in_whitespace:
c = in_getc(in);
if (c == EOF) return TT_EOF;
if ((c >= '\\t' && c <= '\\n') || (c >= '\\f' && c <= '\\r') || c == ' ') goto in_whitespace;
in_ungetc(c, in); goto next;
in_linecomm:
c = in_getc(in);
if (c == EOF) return TT_EOF;
if (c != '\\n') goto in_linecomm;
goto next;
in_numsym:
while (is_numsym(c)) { cbputc(c, pcb); c = in_getc(in); }
if (!is_delimiter(c)) goto err; if (c != EOF) in_ungetc(c, in);
if (cleansymname(cbdata(pcb))) return TT_SYMBOL;
return TT_NUMBER;
after_dot:
c = in_getc(in); if (is_numsym(c)) goto in_numsym;
if (!is_delimiter(c)) goto err; if (c != EOF) in_ungetc(c, in);
return TT_DOT;
after_hash:
c = in_getc(in); if (c == EOF) goto err;
if (c == '(') return TT_OPENVEC;
if (c == '\\\\') { cbclear(pcb); goto in_char; }
if (c == '|') { // handcoded
int level = 1;
normal:
switch (in_getc(in)) {
case EOF: goto err;
case '#': goto after_hashc;
case '|': goto after_barc;
default: goto normal;
}
after_hashc:
switch (in_getc(in)) {
case EOF: goto err;
case '#': goto after_hashc;
case '|': level++;
default: goto normal;
}
after_barc:
switch (in_getc(in)) {
case EOF: goto err;
case '|': goto after_barc;
case '#': if (!--level) goto next;
default: goto normal;
}
}
if (c == '!') { cbclear(pcb); goto after_shebang; }
if (c == '&') return TT_BOX;
if (c == 'u' || c == 'U') { cbputc(tolower(c), cbclear(pcb)); goto after_hashu; }
if (c >= '0' && c <= '9') { cbputc(c, cbclear(pcb)); goto in_hashnum; }
if (c == 'B' || (c >= 'D' && c <= 'E') || c == 'I' || c == 'O' || c == 'X' ||
c == 'b' || (c >= 'd' && c <= 'e') || c == 'i' || c == 'o' || c == 'x')
{ cbputc(tolower(c), pcb); goto in_hashradixie; }
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z'))
{ cbputc(tolower(c), cbclear(pcb)); goto in_hashname; }
if (c == ';') { cbclear(pcb); return TT_HSEMI; } // todo: skip S-exp
in_ungetc(c, in); goto err;
after_comma:
c = in_getc(in);
if (c == EOF) return TT_UNQUOTE;
if (c == '@') return TT_UNQSPL;
in_ungetc(c, in); return TT_UNQUOTE;
in_char:
c = in_getc(in); if (c == EOF) goto eoferr;
if (c == 'x' || c == 'X') goto in_char_xesc;
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) goto in_char_name;
cbputc(c, pcb); // todo: parse utf-8
c = in_getc(in); if (c != EOF) in_ungetc(c, in);
if (!is_delimiter(c)) goto err;
return TT_CHAR;
in_char_name:
while ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { cbputc(c, pcb); c = in_getc(in); }
if (cblen(pcb) > 1) {
char *s = cbdata(pcb); int x = EOF;
if (0 == strcmp(s, \"null\")) x = '\\0';
else if (0 == strcmp(s, \"alarm\")) x = '\\a';
else if (0 == strcmp(s, \"backspace\")) x = '\\b';
else if (0 == strcmp(s, \"delete\")) x = '\\x7F';
else if (0 == strcmp(s, \"escape\")) x = '\\x1B';
else if (0 == strcmp(s, \"newline\")) x = '\\n';
else if (0 == strcmp(s, \"return\")) x = '\\r';
else if (0 == strcmp(s, \"space\")) x = ' ';
else if (0 == strcmp(s, \"tab\")) x = '\\t';
else if (0 == strcmp(s, \"vtab\")) x = '\\v'; //++
else if (0 == strcmp(s, \"page\")) x = '\\f'; //++
else if (0 == strcmp(s, \"linefeed\")) x = '\\n'; //++
if (x == EOF) goto err;
cbputc(x, cbclear(pcb));
}
if (c != EOF) in_ungetc(c, in);
if (!is_delimiter(c)) goto err;
return TT_CHAR;
in_char_xesc:
xc = c; c = in_getc(in);
if (is_delimiter(c)) { if (c != EOF) in_ungetc(c, in); cbputc(xc, pcb); return TT_CHAR; }
else xc = 0;
while (!is_delimiter(c) && (xc = lex_xesc(c, xc)) != EOF) c = in_getc(in);
if (!is_delimiter(c) || xc == EOF) goto err;
if (c != EOF) in_ungetc(c, in); cbputc(xc, pcb); return TT_CHAR; // todo: cbput8c
in_barsym:
c = in_getc(in); if (c == EOF) goto eoferr;
else if (c == '|') return TT_SYMBOL;
else if (c == '\\\\') goto in_barsym_esc;
cbputc(c, pcb); goto in_barsym; // todo: parse utf-8
in_barsym_esc:
c = in_getc(in); if (c == EOF) goto err;
if (c == 'x' || c == 'X') goto in_barsym_xesc;
xc = lex_1esc(c); if (xc == EOF) goto err;
cbputc(xc, pcb); goto in_barsym; // todo: cbput8c
in_barsym_xesc:
xc = 0; do c = in_getc(in);
while (c != ';' && (xc = lex_xesc(c, xc)) != EOF);
if (c != ';' || xc == EOF) goto err;
cbputc(xc, pcb); goto in_barsym; // todo: cbput8c
in_string:
c = in_getc(in); if (c == EOF) goto eoferr;
else if (c == '\\\"') return TT_STRING;
else if (c == '\\\\') goto in_str_esc;
cbputc(c, pcb); goto in_string; // todo: parse utf-8
in_str_esc:
c = in_getc(in); if (c == EOF) goto err;
if (c == 'x' || c == 'X') goto in_str_xesc;
if (c == '\\t' || c == ' ' || c == '\\r' || c == '\\n') goto in_str_sesc;
xc = lex_1esc(c); if (xc == EOF) goto err;
cbputc(xc, pcb); goto in_string; // todo: cbput8c
in_str_sesc:
while (c == '\\t' || c == ' ' || c == '\\r') c = in_getc(in);
if (c != '\\n') goto err;
do c = in_getc(in); while (c == '\\t' || c == ' ');
if (c == EOF) goto err;
in_ungetc(c, in); goto in_string;
in_str_xesc:
xc = 0; do c = in_getc(in);
while (c != ';' && (xc = lex_xesc(c, xc)) != EOF);
if (c != ';' || xc == EOF) goto err;
cbputc(xc, pcb); goto in_string; // todo: cbput8c
in_hashradixie:
c = in_getc(in); if (c == EOF) goto err;
while (is_num(c)) { cbputc(tolower(c), pcb); c = in_getc(in); }
if (!is_delimiter(c)) goto err; if (c != EOF) in_ungetc(c, in);
return TT_NUMBER;
in_hashname:
c = in_getc(in);
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { cbputc(tolower(c), pcb); goto in_hashname; }
if (is_delimiter(c)) {
char *s = cbdata(pcb); if (c != EOF) in_ungetc(c, in);
if (0 == strcmp(s, \"t\")) return TT_TRUE;
else if (0 == strcmp(s, \"true\")) return TT_TRUE;
else if (0 == strcmp(s, \"f\")) return TT_FALSE;
else if (0 == strcmp(s, \"false\")) return TT_FALSE;
}
goto err;
in_hashnum:
c = in_getc(in); if (c == EOF) goto err;
if (c == '#') return TT_HREF;
if (c == '=') return TT_HDEF;
if (c >= '0' && c <= '9') { cbputc(c, pcb); goto in_hashnum; }
in_ungetc(c, in); goto err;
after_hashu:
c = in_getc(in);
if (c == '8') { cbclear(pcb); goto after_hashu8; }
if ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')) { cbputc(tolower(c), pcb); goto in_hashname; }
in_ungetc(c, in); goto err;
after_hashu8:
c = in_getc(in); if (c == EOF) goto err;
if (c == '(') return TT_OPENU8VEC;
in_ungetc(c, in); goto err;
after_shebang:
c = in_getc(in); if (c == EOF) goto err;
if (c == ' ' || c == '\\t') goto in_shebang_line;
else if (c == '-' || (c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || c == '_' || (c >= 'a' && c <= 'z'))
{ cbputc(c, pcb); goto in_shebang_name; }
in_ungetc(c, in); goto err;
in_shebang_line:
while (c == ' ' || c == '\\t') c = in_getc(in);
while (c != EOF && c != '\\n') { cbputc(c, pcb); c = in_getc(in); }
while (pcb->fill > pcb->buf && (pcb->fill[-1] == ' ' || pcb->fill[-1] == '\\t')) pcb->fill -= 1;
return TT_SHEBANG;
in_shebang_name:
c = in_getc(in);
if (c == EOF) goto in_shebang_pre;
else if (c == '-' || (c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || c == '_' || (c >= 'a' && c <= 'z'))
{ cbputc(c, pcb); goto in_shebang_name; }
else { in_ungetc(c, in); goto in_shebang_pre; }
in_shebang_pre: {
char *s = cbdata(pcb);
if (strcmp_ci(s, \"fold-case\") == 0) return TT_SHEBANG_FC;
if (strcmp_ci(s, \"no-fold-case\") == 0) return TT_SHEBANG_NF;
return TT_SHEBANG;
}
err:
eoferr:
return TT_ERR;
}")
Reference in a new issue View git blame Copy permalink