dnrops
/
gimp
mirror of https://github.com/GNOME/gimp.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
gimp/plug-ins/script-fu/siod/sliba.c

2899 lines
61 KiB
C
Raw Blame History

/*
* COPYRIGHT (c) 1988-1994 BY *
* PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
* See the source file SLIB.C for more information. *
Array-hacking code moved to another source file.
*/
#include <stdio.h>
#include <string.h>
#include <setjmp.h>
#include <stdlib.h>
#include <stdarg.h>
#include <ctype.h>
#include <math.h>
#include "siod.h"
#include "siodp.h"
static void
init_sliba_version (void)
{
setvar (cintern ("*sliba-version*"),
cintern ("$Id$"),
NIL);
}
static LISP sym_plists = NIL;
static LISP bashnum = NIL;
static LISP sym_e = NIL;
static LISP sym_f = NIL;
void
init_storage_a1 (long type)
{
long j;
struct user_type_hooks *p;
set_gc_hooks (type,
array_gc_relocate,
array_gc_mark,
array_gc_scan,
array_gc_free,
&j);
set_print_hooks (type, array_prin1);
p = get_user_type_hooks (type);
p->fast_print = array_fast_print;
p->fast_read = array_fast_read;
p->equal = array_equal;
p->c_sxhash = array_sxhash;
}
void
init_storage_a (void)
{
gc_protect (&bashnum);
bashnum = newcell (tc_flonum);
init_storage_a1 (tc_string);
init_storage_a1 (tc_double_array);
init_storage_a1 (tc_long_array);
init_storage_a1 (tc_lisp_array);
init_storage_a1 (tc_byte_array);
}
LISP
array_gc_relocate (LISP ptr)
{
LISP nw;
if ((nw = heap) >= heap_end)
gc_fatal_error ();
heap = nw + 1;
memcpy (nw, ptr, sizeof (struct obj));
return (nw);
}
void
array_gc_scan (LISP ptr)
{
long j;
if TYPEP
(ptr, tc_lisp_array)
for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
ptr->storage_as.lisp_array.data[j] =
gc_relocate (ptr->storage_as.lisp_array.data[j]);
}
LISP
array_gc_mark (LISP ptr)
{
long j;
if TYPEP
(ptr, tc_lisp_array)
for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
gc_mark (ptr->storage_as.lisp_array.data[j]);
return (NIL);
}
void
array_gc_free (LISP ptr)
{
switch (ptr->type)
{
case tc_string:
case tc_byte_array:
free (ptr->storage_as.string.data);
break;
case tc_double_array:
free (ptr->storage_as.double_array.data);
break;
case tc_long_array:
free (ptr->storage_as.long_array.data);
break;
case tc_lisp_array:
free (ptr->storage_as.lisp_array.data);
break;
}
}
void
array_prin1 (LISP ptr, struct gen_printio *f)
{
int j;
switch (ptr->type)
{
case tc_string:
gput_st (f, "\"");
if (strcspn (ptr->storage_as.string.data, "\"\\\n\r\t") ==
strlen (ptr->storage_as.string.data))
gput_st (f, ptr->storage_as.string.data);
else
{
int n, c;
char cbuff[3];
n = strlen (ptr->storage_as.string.data);
for (j = 0; j < n; ++j)
switch (c = ptr->storage_as.string.data[j])
{
case '\\':
case '"':
cbuff[0] = '\\';
cbuff[1] = c;
cbuff[2] = 0;
gput_st (f, cbuff);
break;
case '\n':
gput_st (f, "\\n");
break;
case '\r':
gput_st (f, "\\r");
break;
case '\t':
gput_st (f, "\\t");
break;
default:
cbuff[0] = c;
cbuff[1] = 0;
gput_st (f, cbuff);
break;
}
}
gput_st (f, "\"");
break;
case tc_double_array:
gput_st (f, "#(");
for (j = 0; j < ptr->storage_as.double_array.dim; ++j)
{
sprintf (tkbuffer, "%g", ptr->storage_as.double_array.data[j]);
gput_st (f, tkbuffer);
if ((j + 1) < ptr->storage_as.double_array.dim)
gput_st (f, " ");
}
gput_st (f, ")");
break;
case tc_long_array:
gput_st (f, "#(");
for (j = 0; j < ptr->storage_as.long_array.dim; ++j)
{
sprintf (tkbuffer, "%ld", ptr->storage_as.long_array.data[j]);
gput_st (f, tkbuffer);
if ((j + 1) < ptr->storage_as.long_array.dim)
gput_st (f, " ");
}
gput_st (f, ")");
case tc_byte_array:
sprintf (tkbuffer, "#%ld\"", ptr->storage_as.string.dim);
gput_st (f, tkbuffer);
for (j = 0; j < ptr->storage_as.string.dim; ++j)
{
sprintf (tkbuffer, "%02x", ptr->storage_as.string.data[j] & 0xFF);
gput_st (f, tkbuffer);
}
gput_st (f, "\"");
break;
case tc_lisp_array:
gput_st (f, "#(");
for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
{
lprin1g (ptr->storage_as.lisp_array.data[j], f);
if ((j + 1) < ptr->storage_as.lisp_array.dim)
gput_st (f, " ");
}
gput_st (f, ")");
break;
}
}
LISP
strcons (long length, char *data)
{
long flag;
LISP s;
flag = no_interrupt (1);
s = cons (NIL, NIL);
s->type = tc_string;
if (length == -1)
length = strlen (data);
s->storage_as.string.data = must_malloc (length + 1);
s->storage_as.string.dim = length;
if (data)
memcpy (s->storage_as.string.data, data, length);
s->storage_as.string.data[length] = 0;
no_interrupt (flag);
return (s);
}
int
rfs_getc (unsigned char **p)
{
int i;
i = **p;
if (!i)
return (EOF);
*p = *p + 1;
return (i);
}
void
rfs_ungetc (unsigned char c, unsigned char **p)
{
*p = *p - 1;
}
LISP
read_from_string (LISP x)
{
char *p;
struct gen_readio s;
p = get_c_string (x);
s.getc_fcn = (int (*)(void *)) rfs_getc;
s.ungetc_fcn = (void (*)(int, void *)) rfs_ungetc;
s.cb_argument = (char *) &p;
return (readtl (&s));
}
int
pts_puts (char *from, void *cb)
{
LISP into;
size_t fromlen, intolen, intosize, fitsize;
into = (LISP) cb;
fromlen = strlen (from);
intolen = strlen (into->storage_as.string.data);
intosize = into->storage_as.string.dim - intolen;
fitsize = (fromlen < intosize) ? fromlen : intosize;
memcpy (&into->storage_as.string.data[intolen], from, fitsize);
into->storage_as.string.data[intolen + fitsize] = 0;
if (fitsize < fromlen)
my_err ("print to string overflow", NIL);
return (1);
}
LISP
err_wta_str (LISP exp)
{
return (my_err ("not a string", exp));
}
LISP
print_to_string (LISP exp, LISP str, LISP nostart)
{
struct gen_printio s;
if NTYPEP
(str, tc_string) err_wta_str (str);
s.putc_fcn = NULL;
s.puts_fcn = pts_puts;
s.cb_argument = str;
if NULLP
(nostart)
str->storage_as.string.data[0] = 0;
lprin1g (exp, &s);
return (str);
}
LISP
aref1 (LISP a, LISP i)
{
long k;
if NFLONUMP
(i) my_err ("bad index to aref", i);
k = (long) FLONM (i);
if (k < 0)
my_err ("negative index to aref", i);
switch TYPE
(a)
{
case tc_string:
case tc_byte_array:
if (k >= a->storage_as.string.dim)
my_err ("index too large", i);
return (flocons ((double) a->storage_as.string.data[k]));
case tc_double_array:
if (k >= a->storage_as.double_array.dim)
my_err ("index too large", i);
return (flocons (a->storage_as.double_array.data[k]));
case tc_long_array:
if (k >= a->storage_as.long_array.dim)
my_err ("index too large", i);
return (flocons (a->storage_as.long_array.data[k]));
case tc_lisp_array:
if (k >= a->storage_as.lisp_array.dim)
my_err ("index too large", i);
return (a->storage_as.lisp_array.data[k]);
default:
return (my_err ("invalid argument to aref", a));
}
}
void
err1_aset1 (LISP i)
{
my_err ("index to aset too large", i);
}
void
err2_aset1 (LISP v)
{
my_err ("bad value to store in array", v);
}
LISP
aset1 (LISP a, LISP i, LISP v)
{
long k;
if NFLONUMP
(i) my_err ("bad index to aset", i);
k = (long) FLONM (i);
if (k < 0)
my_err ("negative index to aset", i);
switch TYPE
(a)
{
case tc_string:
case tc_byte_array:
if NFLONUMP
(v) err2_aset1 (v);
if (k >= a->storage_as.string.dim)
err1_aset1 (i);
a->storage_as.string.data[k] = (char) FLONM (v);
return (v);
case tc_double_array:
if NFLONUMP
(v) err2_aset1 (v);
if (k >= a->storage_as.double_array.dim)
err1_aset1 (i);
a->storage_as.double_array.data[k] = FLONM (v);
return (v);
case tc_long_array:
if NFLONUMP
(v) err2_aset1 (v);
if (k >= a->storage_as.long_array.dim)
err1_aset1 (i);
a->storage_as.long_array.data[k] = (long) FLONM (v);
return (v);
case tc_lisp_array:
if (k >= a->storage_as.lisp_array.dim)
err1_aset1 (i);
a->storage_as.lisp_array.data[k] = v;
return (v);
default:
return (my_err ("invalid argument to aset", a));
}
}
LISP
arcons (long typecode, long n, long initp)
{
LISP a;
long flag, j;
flag = no_interrupt (1);
a = cons (NIL, NIL);
switch (typecode)
{
case tc_double_array:
a->storage_as.double_array.dim = n;
a->storage_as.double_array.data = (double *) must_malloc (n *
sizeof (double));
if (initp)
for (j = 0; j < n; ++j)
a->storage_as.double_array.data[j] = 0.0;
break;
case tc_long_array:
a->storage_as.long_array.dim = n;
a->storage_as.long_array.data = (long *) must_malloc (n * sizeof (long));
if (initp)
for (j = 0; j < n; ++j)
a->storage_as.long_array.data[j] = 0;
break;
case tc_string:
a->storage_as.string.dim = n;
a->storage_as.string.data = (char *) must_malloc (n + 1);
a->storage_as.string.data[n] = 0;
if (initp)
for (j = 0; j < n; ++j)
a->storage_as.string.data[j] = ' ';
case tc_byte_array:
a->storage_as.string.dim = n;
a->storage_as.string.data = (char *) must_malloc (n);
if (initp)
for (j = 0; j < n; ++j)
a->storage_as.string.data[j] = 0;
break;
case tc_lisp_array:
a->storage_as.lisp_array.dim = n;
a->storage_as.lisp_array.data = (LISP *) must_malloc (n * sizeof (LISP));
for (j = 0; j < n; ++j)
a->storage_as.lisp_array.data[j] = NIL;
break;
default:
errswitch ();
}
a->type = typecode;
no_interrupt (flag);
return (a);
}
LISP
mallocl (void *place, long size)
{
long n, r;
LISP retval;
n = size / sizeof (long);
r = size % sizeof (long);
if (r)
++n;
retval = arcons (tc_long_array, n, 0);
*(long **) place = retval->storage_as.long_array.data;
return (retval);
}
LISP
cons_array (LISP dim, LISP kind)
{
LISP a;
long flag, n, j;
if (NFLONUMP (dim) || (FLONM (dim) < 0))
return (my_err ("bad dimension to cons-array", dim));
else
n = (long) FLONM (dim);
flag = no_interrupt (1);
a = cons (NIL, NIL);
if EQ
(cintern ("double"), kind)
{
a->type = tc_double_array;
a->storage_as.double_array.dim = n;
a->storage_as.double_array.data = (double *) must_malloc (n *
sizeof (double));
for (j = 0; j < n; ++j)
a->storage_as.double_array.data[j] = 0.0;
}
else if EQ
(cintern ("long"), kind)
{
a->type = tc_long_array;
a->storage_as.long_array.dim = n;
a->storage_as.long_array.data = (long *) must_malloc (n * sizeof (long));
for (j = 0; j < n; ++j)
a->storage_as.long_array.data[j] = 0;
}
else if EQ
(cintern ("string"), kind)
{
a->type = tc_string;
a->storage_as.string.dim = n;
a->storage_as.string.data = (char *) must_malloc (n + 1);
a->storage_as.string.data[n] = 0;
for (j = 0; j < n; ++j)
a->storage_as.string.data[j] = ' ';
}
else if EQ
(cintern ("byte"), kind)
{
a->type = tc_byte_array;
a->storage_as.string.dim = n;
a->storage_as.string.data = (char *) must_malloc (n);
for (j = 0; j < n; ++j)
a->storage_as.string.data[j] = 0;
}
else if (EQ (cintern ("lisp"), kind) || NULLP (kind))
{
a->type = tc_lisp_array;
a->storage_as.lisp_array.dim = n;
a->storage_as.lisp_array.data = (LISP *) must_malloc (n * sizeof (LISP));
for (j = 0; j < n; ++j)
a->storage_as.lisp_array.data[j] = NIL;
}
else
my_err ("bad type of array", kind);
no_interrupt (flag);
return (a);
}
LISP
string_append (LISP args)
{
long size;
LISP l, s;
char *data;
size = 0;
for (l = args; NNULLP (l); l = cdr (l))
size += strlen (get_c_string (car (l)));
s = strcons (size, NULL);
data = s->storage_as.string.data;
data[0] = 0;
for (l = args; NNULLP (l); l = cdr (l))
strcat (data, get_c_string (car (l)));
return (s);
}
LISP
bytes_append (LISP args)
{
long size, n, j;
LISP l, s;
char *data, *ptr;
size = 0;
for (l = args; NNULLP (l); l = cdr (l))
{
get_c_string_dim (car (l), &n);
size += n;
}
s = arcons (tc_byte_array, size, 0);
data = s->storage_as.string.data;
for (j = 0, l = args; NNULLP (l); l = cdr (l))
{
ptr = get_c_string_dim (car (l), &n);
memcpy (&data[j], ptr, n);
j += n;
}
return (s);
}
LISP
substring (LISP str, LISP start, LISP end)
{
long s, e, n;
char *data;
data = get_c_string_dim (str, &n);
s = get_c_long (start);
if NULLP
(end)
e = n;
else
e = get_c_long (end);
if ((s < 0) || (s > e))
my_err ("bad start index", start);
if ((e < 0) || (e > n))
my_err ("bad end index", end);
return (strcons (e - s, &data[s]));
}
LISP
string_search (LISP token, LISP str)
{
char *s1, *s2, *ptr;
s1 = get_c_string (str);
s2 = get_c_string (token);
ptr = strstr (s1, s2);
if (ptr)
return (flocons (ptr - s1));
else
return (NIL);
}
#define IS_TRIM_SPACE(_x) (strchr(" \t\r\n",(_x)))
LISP
string_trim (LISP str)
{
char *start, *end; /*, *sp = " \t\r\n";*/
start = get_c_string (str);
while (*start && IS_TRIM_SPACE (*start))
++start;
end = &start[strlen (start)];
while ((end > start) && IS_TRIM_SPACE (*(end - 1)))
--end;
return (strcons (end - start, start));
}
LISP
string_trim_left (LISP str)
{
char *start, *end;
start = get_c_string (str);
while (*start && IS_TRIM_SPACE (*start))
++start;
end = &start[strlen (start)];
return (strcons (end - start, start));
}
LISP
string_trim_right (LISP str)
{
char *start, *end;
start = get_c_string (str);
end = &start[strlen (start)];
while ((end > start) && IS_TRIM_SPACE (*(end - 1)))
--end;
return (strcons (end - start, start));
}
LISP
string_upcase (LISP str)
{
LISP result;
char *s1, *s2;
long j, n;
s1 = get_c_string (str);
n = strlen (s1);
result = strcons (n, s1);
s2 = get_c_string (result);
for (j = 0; j < n; ++j)
s2[j] = toupper (s2[j]);
return (result);
}
LISP
string_downcase (LISP str)
{
LISP result;
char *s1, *s2;
long j, n;
s1 = get_c_string (str);
n = strlen (s1);
result = strcons (n, s1);
s2 = get_c_string (result);
for (j = 0; j < n; ++j)
s2[j] = tolower (s2[j]);
return (result);
}
LISP
lreadstring (struct gen_readio * f)
{
int j, c, n;
char *p;
j = 0;
p = tkbuffer;
while (((c = GETC_FCN (f)) != '"') && (c != EOF))
{
if (c == '\\')
{
c = GETC_FCN (f);
if (c == EOF)
my_err ("eof after \\", NIL);
switch (c)
{
case 'n':
c = '\n';
break;
case 't':
c = '\t';
break;
case 'r':
c = '\r';
break;
case 'd':
c = 0x04;
break;
case 'N':
c = 0;
break;
case 's':
c = ' ';
break;
case '0':
n = 0;
while (1)
{
c = GETC_FCN (f);
if (c == EOF)
my_err ("eof after \\0", NIL);
if (isdigit (c))
n = n * 8 + c - '0';
else
{
UNGETC_FCN (c, f);
break;
}
}
c = n;
}
}
if ((j + 1) >= TKBUFFERN)
my_err ("read string overflow", NIL);
++j;
*p++ = c;
}
*p = 0;
return (strcons (j, tkbuffer));
}
LISP
lreadsharp (struct gen_readio * f)
{
LISP obj, l, result;
long j, n;
int c;
c = GETC_FCN (f);
switch (c)
{
case '(':
UNGETC_FCN (c, f);
obj = lreadr (f);
n = nlength (obj);
result = arcons (tc_lisp_array, n, 1);
for (l = obj, j = 0; j < n; l = cdr (l), ++j)
result->storage_as.lisp_array.data[j] = car (l);
return (result);
case '.':
obj = lreadr (f);
return (leval (obj, NIL));
case 'f':
return (NIL);
case 't':
return (flocons (1));
default:
return (my_err ("readsharp syntax not handled", NIL));
}
}
#define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod))
long
c_sxhash (LISP obj, long n)
{
long hash;
unsigned char *s;
LISP tmp;
struct user_type_hooks *p;
STACK_CHECK (&obj);
INTERRUPT_CHECK ();
switch TYPE
(obj)
{
case tc_nil:
return (0);
case tc_cons:
hash = c_sxhash (CAR (obj), n);
for (tmp = CDR (obj); CONSP (tmp); tmp = CDR (tmp))
hash = HASH_COMBINE (hash, c_sxhash (CAR (tmp), n), n);
hash = HASH_COMBINE (hash, c_sxhash (tmp, n), n);
return (hash);
case tc_symbol:
for (hash = 0, s = (unsigned char *) PNAME (obj); *s; ++s)
hash = HASH_COMBINE (hash, *s, n);
return (hash);
case tc_subr_0:
case tc_subr_1:
case tc_subr_2:
case tc_subr_3:
case tc_subr_4:
case tc_subr_5:
case tc_lsubr:
case tc_fsubr:
case tc_msubr:
for (hash = 0, s = (unsigned char *) obj->storage_as.subr.name; *s; ++s)
hash = HASH_COMBINE (hash, *s, n);
return (hash);
case tc_flonum:
return (((unsigned long) FLONM (obj)) % n);
default:
p = get_user_type_hooks (TYPE (obj));
if (p->c_sxhash)
return ((*p->c_sxhash) (obj, n));
else
return (0);
}
}
LISP
sxhash (LISP obj, LISP n)
{
return (flocons (c_sxhash (obj, FLONUMP (n) ? (long) FLONM (n) : 10000)));
}
LISP
equal (LISP a, LISP b)
{
struct user_type_hooks *p;
long atype;
STACK_CHECK (&a);
loop:
INTERRUPT_CHECK ();
if EQ
(a, b) return (sym_t);
atype = TYPE (a);
if (atype != TYPE (b))
return (NIL);
switch (atype)
{
case tc_cons:
if NULLP
(equal (car (a), car (b))) return (NIL);
a = cdr (a);
b = cdr (b);
goto loop;
case tc_flonum:
return ((FLONM (a) == FLONM (b)) ? sym_t : NIL);
case tc_symbol:
return (NIL);
default:
p = get_user_type_hooks (atype);
if (p->equal)
return ((*p->equal) (a, b));
else
return (NIL);
}
}
LISP
array_equal (LISP a, LISP b)
{
long j, len;
switch (TYPE (a))
{
case tc_string:
case tc_byte_array:
len = a->storage_as.string.dim;
if (len != b->storage_as.string.dim)
return (NIL);
if (memcmp (a->storage_as.string.data, b->storage_as.string.data, len) == 0)
return (sym_t);
else
return (NIL);
case tc_long_array:
len = a->storage_as.long_array.dim;
if (len != b->storage_as.long_array.dim)
return (NIL);
if (memcmp (a->storage_as.long_array.data,
b->storage_as.long_array.data,
len * sizeof (long)) == 0)
return (sym_t);
else
return (NIL);
case tc_double_array:
len = a->storage_as.double_array.dim;
if (len != b->storage_as.double_array.dim)
return (NIL);
for (j = 0; j < len; ++j)
if (a->storage_as.double_array.data[j] !=
b->storage_as.double_array.data[j])
return (NIL);
return (sym_t);
case tc_lisp_array:
len = a->storage_as.lisp_array.dim;
if (len != b->storage_as.lisp_array.dim)
return (NIL);
for (j = 0; j < len; ++j)
if NULLP
(equal (a->storage_as.lisp_array.data[j],
b->storage_as.lisp_array.data[j]))
return (NIL);
return (sym_t);
default:
return (errswitch ());
}
}
long
array_sxhash (LISP a, long n)
{
long j, len, hash;
unsigned char *char_data;
unsigned long *long_data;
double *double_data;
switch (TYPE (a))
{
case tc_string:
case tc_byte_array:
len = a->storage_as.string.dim;
for (j = 0, hash = 0, char_data = (unsigned char *) a->storage_as.string.data;
j < len;
++j, ++char_data)
hash = HASH_COMBINE (hash, *char_data, n);
return (hash);
case tc_long_array:
len = a->storage_as.long_array.dim;
for (j = 0, hash = 0, long_data = (unsigned long *) a->storage_as.long_array.data;
j < len;
++j, ++long_data)
hash = HASH_COMBINE (hash, *long_data % n, n);
return (hash);
case tc_double_array:
len = a->storage_as.double_array.dim;
for (j = 0, hash = 0, double_data = a->storage_as.double_array.data;
j < len;
++j, ++double_data)
hash = HASH_COMBINE (hash, (unsigned long) *double_data % n, n);
return (hash);
case tc_lisp_array:
len = a->storage_as.lisp_array.dim;
for (j = 0, hash = 0; j < len; ++j)
hash = HASH_COMBINE (hash,
c_sxhash (a->storage_as.lisp_array.data[j], n),
n);
return (hash);
default:
errswitch ();
return (0);
}
}
long
href_index (LISP table, LISP key)
{
long index;
if NTYPEP
(table, tc_lisp_array) my_err ("not a hash table", table);
index = c_sxhash (key, table->storage_as.lisp_array.dim);
if ((index < 0) || (index >= table->storage_as.lisp_array.dim))
{
my_err ("sxhash inconsistency", table);
return (0);
}
else
return (index);
}
LISP
href (LISP table, LISP key)
{
return (cdr (assoc (key,
table->storage_as.lisp_array.data[href_index (table, key)])));
}
LISP
hset (LISP table, LISP key, LISP value)
{
long index;
LISP cell, l;
index = href_index (table, key);
l = table->storage_as.lisp_array.data[index];
if NNULLP
(cell = assoc (key, l))
return (setcdr (cell, value));
cell = cons (key, value);
table->storage_as.lisp_array.data[index] = cons (cell, l);
return (value);
}
LISP
assoc (LISP x, LISP alist)
{
LISP l, tmp;
for (l = alist; CONSP (l); l = CDR (l))
{
tmp = CAR (l);
if (CONSP (tmp) && equal (CAR (tmp), x))
return (tmp);
INTERRUPT_CHECK ();
}
if EQ
(l, NIL) return (NIL);
return (my_err ("improper list to assoc", alist));
}
LISP
assv (LISP x, LISP alist)
{
LISP l, tmp;
for (l = alist; CONSP (l); l = CDR (l))
{
tmp = CAR (l);
if (CONSP (tmp) && NNULLP (eql (CAR (tmp), x)))
return (tmp);
INTERRUPT_CHECK ();
}
if EQ
(l, NIL) return (NIL);
return (my_err ("improper list to assv", alist));
}
void
put_long (long i, FILE * f)
{
fwrite (&i, sizeof (long), 1, f);
}
long
get_long (FILE * f)
{
long i;
fread (&i, sizeof (long), 1, f);
return (i);
}
long
fast_print_table (LISP obj, LISP table)
{
FILE *f;
LISP ht, index;
f = get_c_file (car (table), (FILE *) NULL);
if NULLP
(ht = car (cdr (table)))
return (1);
index = href (ht, obj);
if NNULLP
(index)
{
putc (FO_fetch, f);
put_long (get_c_long (index), f);
return (0);
}
if NULLP
(index = car (cdr (cdr (table))))
return (1);
hset (ht, obj, index);
FLONM (bashnum) = 1.0;
setcar (cdr (cdr (table)), plus (index, bashnum));
putc (FO_store, f);
put_long (get_c_long (index), f);
return (1);
}
LISP
fast_print (LISP obj, LISP table)
{
FILE *f;
long len;
LISP tmp;
struct user_type_hooks *p;
STACK_CHECK (&obj);
f = get_c_file (car (table), (FILE *) NULL);
switch (TYPE (obj))
{
case tc_nil:
putc (tc_nil, f);
return (NIL);
case tc_cons:
for (len = 0, tmp = obj; CONSP (tmp); tmp = CDR (tmp))
{
INTERRUPT_CHECK ();
++len;
}
if (len == 1)
{
putc (tc_cons, f);
fast_print (car (obj), table);
fast_print (cdr (obj), table);
}
else if NULLP
(tmp)
{
putc (FO_list, f);
put_long (len, f);
for (tmp = obj; CONSP (tmp); tmp = CDR (tmp))
fast_print (CAR (tmp), table);
}
else
{
putc (FO_listd, f);
put_long (len, f);
for (tmp = obj; CONSP (tmp); tmp = CDR (tmp))
fast_print (CAR (tmp), table);
fast_print (tmp, table);
}
return (NIL);
case tc_flonum:
putc (tc_flonum, f);
fwrite (&obj->storage_as.flonum.data,
sizeof (obj->storage_as.flonum.data),
1,
f);
return (NIL);
case tc_symbol:
if (fast_print_table (obj, table))
{
putc (tc_symbol, f);
len = strlen (PNAME (obj));
if (len >= TKBUFFERN)
my_err ("symbol name too long", obj);
put_long (len, f);
fwrite (PNAME (obj), len, 1, f);
return (sym_t);
}
else
return (NIL);
default:
p = get_user_type_hooks (TYPE (obj));
if (p->fast_print)
return ((*p->fast_print) (obj, table));
else
return (my_err ("cannot fast-print", obj));
}
}
LISP
fast_read (LISP table)
{
FILE *f;
LISP tmp, l;
struct user_type_hooks *p;
int c;
long len;
f = get_c_file (car (table), (FILE *) NULL);
c = getc (f);
if (c == EOF)
return (table);
switch (c)
{
case FO_comment:
while ((c = getc (f)))
switch (c)
{
case EOF:
return (table);
case '\n':
return (fast_read (table));
}
case FO_fetch:
len = get_long (f);
FLONM (bashnum) = len;
return (href (car (cdr (table)), bashnum));
case FO_store:
len = get_long (f);
tmp = fast_read (table);
hset (car (cdr (table)), flocons (len), tmp);
return (tmp);
case tc_nil:
return (NIL);
case tc_cons:
tmp = fast_read (table);
return (cons (tmp, fast_read (table)));
case FO_list:
case FO_listd:
len = get_long (f);
FLONM (bashnum) = len;
l = make_list (bashnum, NIL);
tmp = l;
while (len > 1)
{
CAR (tmp) = fast_read (table);
tmp = CDR (tmp);
--len;
}
CAR (tmp) = fast_read (table);
if (c == FO_listd)
CDR (tmp) = fast_read (table);
return (l);
case tc_flonum:
tmp = newcell (tc_flonum);
fread (&tmp->storage_as.flonum.data,
sizeof (tmp->storage_as.flonum.data),
1,
f);
return (tmp);
case tc_symbol:
len = get_long (f);
if (len >= TKBUFFERN)
my_err ("symbol name too long", NIL);
fread (tkbuffer, len, 1, f);
tkbuffer[len] = 0;
return (rintern (tkbuffer));
default:
p = get_user_type_hooks (c);
if (p->fast_read)
return (*p->fast_read) (c, table);
else
return (my_err ("unknown fast-read opcode", flocons (c)));
}
}
LISP
array_fast_print (LISP ptr, LISP table)
{
int j, len;
FILE *f;
f = get_c_file (car (table), (FILE *) NULL);
switch (ptr->type)
{
case tc_string:
case tc_byte_array:
putc (ptr->type, f);
len = ptr->storage_as.string.dim;
put_long (len, f);
fwrite (ptr->storage_as.string.data, len, 1, f);
return (NIL);
case tc_double_array:
putc (tc_double_array, f);
len = ptr->storage_as.double_array.dim * sizeof (double);
put_long (len, f);
fwrite (ptr->storage_as.double_array.data, len, 1, f);
return (NIL);
case tc_long_array:
putc (tc_long_array, f);
len = ptr->storage_as.long_array.dim * sizeof (long);
put_long (len, f);
fwrite (ptr->storage_as.long_array.data, len, 1, f);
return (NIL);
case tc_lisp_array:
putc (tc_lisp_array, f);
len = ptr->storage_as.lisp_array.dim;
put_long (len, f);
for (j = 0; j < len; ++j)
fast_print (ptr->storage_as.lisp_array.data[j], table);
return (NIL);
default:
return (errswitch ());
}
}
LISP
array_fast_read (int code, LISP table)
{
long j, len, iflag;
FILE *f;
LISP ptr;
f = get_c_file (car (table), (FILE *) NULL);
switch (code)
{
case tc_string:
len = get_long (f);
ptr = strcons (len, NULL);
fread (ptr->storage_as.string.data, len, 1, f);
ptr->storage_as.string.data[len] = 0;
return (ptr);
case tc_byte_array:
len = get_long (f);
iflag = no_interrupt (1);
ptr = newcell (tc_byte_array);
ptr->storage_as.string.dim = len;
ptr->storage_as.string.data =
(char *) must_malloc (len);
fread (ptr->storage_as.string.data, len, 1, f);
no_interrupt (iflag);
return (ptr);
case tc_double_array:
len = get_long (f);
iflag = no_interrupt (1);
ptr = newcell (tc_double_array);
ptr->storage_as.double_array.dim = len;
ptr->storage_as.double_array.data =
(double *) must_malloc (len * sizeof (double));
fread (ptr->storage_as.double_array.data, sizeof (double), len, f);
no_interrupt (iflag);
return (ptr);
case tc_long_array:
len = get_long (f);
iflag = no_interrupt (1);
ptr = newcell (tc_long_array);
ptr->storage_as.long_array.dim = len;
ptr->storage_as.long_array.data =
(long *) must_malloc (len * sizeof (long));
fread (ptr->storage_as.long_array.data, sizeof (long), len, f);
no_interrupt (iflag);
return (ptr);
case tc_lisp_array:
len = get_long (f);
FLONM (bashnum) = len;
ptr = cons_array (bashnum, NIL);
for (j = 0; j < len; ++j)
ptr->storage_as.lisp_array.data[j] = fast_read (table);
return (ptr);
default:
return (errswitch ());
}
}
long
get_c_long (LISP x)
{
if NFLONUMP
(x) my_err ("not a number", x);
return ((long) FLONM (x));
}
double
get_c_double (LISP x)
{
if NFLONUMP
(x) my_err ("not a number", x);
return (FLONM (x));
}
LISP
make_list (LISP x, LISP v)
{
long n;
LISP l;
n = get_c_long (x);
l = NIL;
while (n > 0)
{
l = cons (v, l);
--n;
}
return (l);
}
LISP
lfread (LISP size, LISP file)
{
long flag, n, ret, m;
char *buffer;
LISP s;
FILE *f;
f = get_c_file (file, stdin);
flag = no_interrupt (1);
switch (TYPE (size))
{
case tc_string:
case tc_byte_array:
s = size;
buffer = s->storage_as.string.data;
n = s->storage_as.string.dim;
m = 0;
break;
default:
n = get_c_long (size);
buffer = (char *) must_malloc (n + 1);
buffer[n] = 0;
m = 1;
}
ret = fread (buffer, 1, n, f);
if (ret == 0)
{
if (m)
free (buffer);
no_interrupt (flag);
return (NIL);
}
if (m)
{
if (ret == n)
{
s = cons (NIL, NIL);
s->type = tc_string;
s->storage_as.string.data = buffer;
s->storage_as.string.dim = n;
}
else
{
s = strcons (ret, NULL);
memcpy (s->storage_as.string.data, buffer, ret);
free (buffer);
}
no_interrupt (flag);
return (s);
}
no_interrupt (flag);
return (flocons ((double) ret));
}
LISP
lfwrite (LISP string, LISP file)
{
FILE *f;
long flag;
char *data;
long dim, len;
f = get_c_file (file, stdout);
data = get_c_string_dim (CONSP (string) ? car (string) : string, &dim);
len = CONSP (string) ? get_c_long (cadr (string)) : dim;
if (len <= 0)
return (NIL);
if (len > dim)
my_err ("write length too long", string);
flag = no_interrupt (1);
fwrite (data, 1, len, f);
no_interrupt (flag);
return (NIL);
}
LISP
lfflush (LISP file)
{
FILE *f;
long flag;
f = get_c_file (file, stdout);
flag = no_interrupt (1);
fflush (f);
no_interrupt (flag);
return (NIL);
}
LISP
string_length (LISP string)
{
if NTYPEP
(string, tc_string) err_wta_str (string);
return (flocons (strlen (string->storage_as.string.data)));
}
LISP
string_dim (LISP string)
{
if NTYPEP
(string, tc_string) err_wta_str (string);
return (flocons ((double) string->storage_as.string.dim));
}
long
nlength (LISP obj)
{
LISP l;
long n;
switch TYPE
(obj)
{
case tc_string:
return (strlen (obj->storage_as.string.data));
case tc_byte_array:
return (obj->storage_as.string.dim);
case tc_double_array:
return (obj->storage_as.double_array.dim);
case tc_long_array:
return (obj->storage_as.long_array.dim);
case tc_lisp_array:
return (obj->storage_as.lisp_array.dim);
case tc_nil:
return (0);
case tc_cons:
for (l = obj, n = 0; CONSP (l); l = CDR (l), ++n)
INTERRUPT_CHECK ();
if NNULLP
(l) my_err ("improper list to length", obj);
return (n);
default:
my_err ("wta to length", obj);
return (0);
}
}
LISP
llength (LISP obj)
{
return (flocons (nlength (obj)));
}
LISP
number2string (LISP x, LISP b, LISP w, LISP p)
{
char buffer[1000];
double y;
long base, width, prec;
if NFLONUMP
(x) my_err ("wta", x);
y = FLONM (x);
width = NNULLP (w) ? get_c_long (w) : -1;
if (width > 100)
my_err ("width too long", w);
prec = NNULLP (p) ? get_c_long (p) : -1;
if (prec > 100)
my_err ("precision too large", p);
if (NULLP (b) || EQ (sym_e, b) || EQ (sym_f, b))
{
if ((width >= 0) && (prec >= 0))
sprintf (buffer,
NULLP (b) ? "% *.*g" : EQ (sym_e, b) ? "% *.*e" : "% *.*f",
width,
prec,
y);
else if (width >= 0)
sprintf (buffer,
NULLP (b) ? "% *g" : EQ (sym_e, b) ? "% *e" : "% *f",
width,
y);
else if (prec >= 0)
sprintf (buffer,
NULLP (b) ? "%.*g" : EQ (sym_e, b) ? "%.*e" : "%.*f",
prec,
y);
else
sprintf (buffer,
NULLP (b) ? "%g" : EQ (sym_e, b) ? "%e" : "%f",
y);
}
else if (((base = get_c_long (b)) == 10) || (base == 8) || (base == 16))
{
if (width >= 0)
sprintf (buffer,
(base == 10) ? "%0*ld" : (base == 8) ? "%0*lo" : "%0*lX",
width,
(long) y);
else
sprintf (buffer,
(base == 10) ? "%ld" : (base == 8) ? "%lo" : "%lX",
(long) y);
}
else
my_err ("number base not handled", b);
return (strcons (strlen (buffer), buffer));
}
LISP
string2number (LISP x, LISP b)
{
char *str;
long base, value = 0;
double result = 0.0;
str = get_c_string (x);
if NULLP
(b)
result = atof (str);
else if ((base = get_c_long (b)) == 10)
{
sscanf (str, "%ld", &value);
result = (double) value;
}
else if (base == 8)
{
sscanf (str, "%lo", &value);
result = (double) value;
}
else if (base == 16)
{
sscanf (str, "%lx", &value);
result = (double) value;
}
else if ((base >= 1) && (base <= 16))
{
for (result = 0.0; *str; ++str)
if (isdigit (*str))
result = result * base + *str - '0';
else if (isxdigit (*str))
result = result * base + toupper (*str) - 'A' + 10;
}
else
my_err ("number base not handled", b);
return (flocons (result));
}
LISP
lstrcmp (LISP s1, LISP s2)
{
return (flocons (strcmp (get_c_string (s1), get_c_string (s2))));
}
void
chk_string (LISP s, char **data, long *dim)
{
if TYPEP
(s, tc_string)
{
*data = s->storage_as.string.data;
*dim = s->storage_as.string.dim;
}
else
err_wta_str (s);
}
LISP
lstrcpy (LISP dest, LISP src)
{
long ddim, slen;
char *d, *s;
chk_string (dest, &d, &ddim);
s = get_c_string (src);
slen = strlen (s);
if (slen > ddim)
my_err ("string too long", src);
memcpy (d, s, slen);
d[slen] = 0;
return (NIL);
}
LISP
lstrcat (LISP dest, LISP src)
{
long ddim, dlen, slen;
char *d, *s;
chk_string (dest, &d, &ddim);
s = get_c_string (src);
slen = strlen (s);
dlen = strlen (d);
if ((slen + dlen) > ddim)
my_err ("string too long", src);
memcpy (&d[dlen], s, slen);
d[dlen + slen] = 0;
return (NIL);
}
LISP
lstrbreakup (LISP str, LISP lmarker)
{
char *start, *end, *marker;
size_t k;
LISP result = NIL;
start = get_c_string (str);
marker = get_c_string (lmarker);
k = strlen (marker);
while (*start)
{
if (!(end = strstr (start, marker)))
end = &start[strlen (start)];
result = cons (strcons (end - start, start), result);
start = (*end) ? end + k : end;
}
return (nreverse (result));
}
LISP
lstrunbreakup (LISP elems, LISP lmarker)
{
LISP result, l;
for (l = elems, result = NIL; NNULLP (l); l = cdr (l))
if EQ
(l, elems)
result = cons (car (l), result);
else
result = cons (car (l), cons (lmarker, result));
return (string_append (nreverse (result)));
}
LISP
stringp (LISP x)
{
return (TYPEP (x, tc_string) ? sym_t : NIL);
}
static char *base64_encode_table = "\
ABCDEFGHIJKLMNOPQRSTUVWXYZ\
abcdefghijklmnopqrstuvwxyz\
0123456789+/=";
static char *base64_decode_table = NULL;
static void
init_base64_table (void)
{
int j;
base64_decode_table = (char *) malloc (256);
memset (base64_decode_table, -1, 256);
for (j = 0; j < 65; ++j)
base64_decode_table[(unsigned char) base64_encode_table[j]] = j;
}
#define BITMSK(N) ((1 << (N)) - 1)
#define ITEM1(X) (X >> 2) & BITMSK(6)
#define ITEM2(X,Y) ((X & BITMSK(2)) << 4) | ((Y >> 4) & BITMSK(4))
#define ITEM3(X,Y) ((X & BITMSK(4)) << 2) | ((Y >> 6) & BITMSK(2))
#define ITEM4(X) X & BITMSK(6)
LISP
base64encode (LISP in)
{
char *s, *t = base64_encode_table;
unsigned char *p1, *p2;
LISP out;
long j, m, n, chunks, leftover;
s = get_c_string_dim (in, &n);
chunks = n / 3;
leftover = n % 3;
m = (chunks + ((leftover) ? 1 : 0)) * 4;
out = strcons (m, NULL);
p2 = (unsigned char *) get_c_string (out);
for (j = 0, p1 = (unsigned char *) s; j < chunks; ++j, p1 += 3)
{
*p2++ = t[ITEM1 (p1[0])];
*p2++ = t[ITEM2 (p1[0], p1[1])];
*p2++ = t[ITEM3 (p1[1], p1[2])];
*p2++ = t[ITEM4 (p1[2])];
}
switch (leftover)
{
case 0:
break;
case 1:
*p2++ = t[ITEM1 (p1[0])];
*p2++ = t[ITEM2 (p1[0], 0)];
*p2++ = base64_encode_table[64];
*p2++ = base64_encode_table[64];
break;
case 2:
*p2++ = t[ITEM1 (p1[0])];
*p2++ = t[ITEM2 (p1[0], p1[1])];
*p2++ = t[ITEM3 (p1[1], 0)];
*p2++ = base64_encode_table[64];
break;
default:
errswitch ();
}
return (out);
}
LISP
base64decode (LISP in)
{
char *s, *t = base64_decode_table;
LISP out;
unsigned char *p1, *p2;
long j, m, n, chunks, leftover, item1, item2, item3, item4;
s = get_c_string (in);
n = strlen (s);
if (n == 0)
return (strcons (0, NULL));
if (n % 4)
my_err ("illegal base64 data length", in);
if (s[n - 1] == base64_encode_table[64])
{
if (s[n - 2] == base64_encode_table[64])
leftover = 1;
else
leftover = 2;
}
else
leftover = 0;
chunks = (n / 4) - ((leftover) ? 1 : 0);
m = (chunks * 3) + leftover;
out = strcons (m, NULL);
p2 = (unsigned char *) get_c_string (out);
for (j = 0, p1 = (unsigned char *) s; j < chunks; ++j, p1 += 4)
{
if ((item1 = t[p1[0]]) & ~BITMSK (6))
return (NIL);
if ((item2 = t[p1[1]]) & ~BITMSK (6))
return (NIL);
if ((item3 = t[p1[2]]) & ~BITMSK (6))
return (NIL);
if ((item4 = t[p1[3]]) & ~BITMSK (6))
return (NIL);
*p2++ = (item1 << 2) | (item2 >> 4);
*p2++ = (item2 << 4) | (item3 >> 2);
*p2++ = (item3 << 6) | item4;
}
switch (leftover)
{
case 0:
break;
case 1:
if ((item1 = t[p1[0]]) & ~BITMSK (6))
return (NIL);
if ((item2 = t[p1[1]]) & ~BITMSK (6))
return (NIL);
*p2++ = (item1 << 2) | (item2 >> 4);
break;
case 2:
if ((item1 = t[p1[0]]) & ~BITMSK (6))
return (NIL);
if ((item2 = t[p1[1]]) & ~BITMSK (6))
return (NIL);
if ((item3 = t[p1[2]]) & ~BITMSK (6))
return (NIL);
*p2++ = (item1 << 2) | (item2 >> 4);
*p2++ = (item2 << 4) | (item3 >> 2);
break;
default:
errswitch ();
}
return (out);
}
LISP
memq (LISP x, LISP il)
{
LISP l, tmp;
for (l = il; CONSP (l); l = CDR (l))
{
tmp = CAR (l);
if EQ
(x, tmp) return (l);
INTERRUPT_CHECK ();
}
if EQ
(l, NIL) return (NIL);
return (my_err ("improper list to memq", il));
}
LISP
member (LISP x, LISP il)
{
LISP l, tmp;
for (l = il; CONSP (l); l = CDR (l))
{
tmp = CAR (l);
if NNULLP
(equal (x, tmp)) return (l);
INTERRUPT_CHECK ();
}
if EQ
(l, NIL) return (NIL);
return (my_err ("improper list to member", il));
}
LISP
memv (LISP x, LISP il)
{
LISP l, tmp;
for (l = il; CONSP (l); l = CDR (l))
{
tmp = CAR (l);
if NNULLP
(eql (x, tmp)) return (l);
INTERRUPT_CHECK ();
}
if EQ
(l, NIL) return (NIL);
return (my_err ("improper list to memv", il));
}
LISP
nth (LISP x, LISP li)
{
LISP l;
long j, n = get_c_long (x);
for (j = 0, l = li; (j < n) && CONSP (l); ++j)
l = CDR (l);
if CONSP
(l)
return (CAR (l));
else
return (my_err ("bad arg to nth", x));
}
/* these lxxx_default functions are convenient for manipulating
command-line argument lists */
LISP
lref_default (LISP li, LISP x, LISP fcn)
{
LISP l;
long j, n = get_c_long (x);
for (j = 0, l = li; (j < n) && CONSP (l); ++j)
l = CDR (l);
if CONSP
(l)
return (CAR (l));
else if NNULLP
(fcn)
return (lapply (fcn, NIL));
else
return (NIL);
}
LISP
larg_default (LISP li, LISP x, LISP dval)
{
LISP l = li, elem;
long j = 0, n = get_c_long (x);
while NNULLP
(l)
{
elem = car (l);
if (TYPEP (elem, tc_string) && strchr ("-:", *get_c_string (elem)))
l = cdr (l);
else if (j == n)
return (elem);
else
{
l = cdr (l);
++j;
}
}
return (dval);
}
LISP
lkey_default (LISP li, LISP key, LISP dval)
{
LISP l = li, elem;
char *ckey, *celem;
long n;
ckey = get_c_string (key);
n = strlen (ckey);
while NNULLP
(l)
{
elem = car (l);
if (TYPEP (elem, tc_string) && (*(celem = get_c_string (elem)) == ':') &&
(strncmp (&celem[1], ckey, n) == 0) && (celem[n + 1] == '='))
return (strcons (strlen (&celem[n + 2]), &celem[n + 2]));
l = cdr (l);
}
return (dval);
}
LISP
llist (LISP l)
{
return (l);
}
LISP
writes1 (FILE * f, LISP l)
{
LISP v;
STACK_CHECK (&v);
INTERRUPT_CHECK ();
for (v = l; CONSP (v); v = CDR (v))
writes1 (f, CAR (v));
switch TYPE
(v)
{
case tc_nil:
break;
case tc_symbol:
case tc_string:
fput_st (f, get_c_string (v));
break;
default:
lprin1f (v, f);
break;
}
return (NIL);
}
LISP
writes (LISP args)
{
return (writes1 (get_c_file (car (args), stdout), cdr (args)));
}
LISP
last (LISP l)
{
LISP v1, v2;
v1 = l;
v2 = CONSP (v1) ? CDR (v1) : my_err ("bad arg to last", l);
while (CONSP (v2))
{
INTERRUPT_CHECK ();
v1 = v2;
v2 = CDR (v2);
}
return (v1);
}
LISP
butlast (LISP l)
{
INTERRUPT_CHECK ();
STACK_CHECK (&l);
if NULLP
(l) my_err ("list is empty", l);
if CONSP (l)
{
if NULLP (CDR (l))
return (NIL);
else
return (cons (CAR (l), butlast (CDR (l))));
}
return (my_err ("not a list", l));
}
LISP
nconc (LISP a, LISP b)
{
if NULLP
(a)
return (b);
setcdr (last (a), b);
return (a);
}
LISP
funcall1 (LISP fcn, LISP a1)
{
switch TYPE
(fcn)
{
case tc_subr_1:
STACK_CHECK (&fcn);
INTERRUPT_CHECK ();
return (SUBR1 (fcn) (a1));
case tc_closure:
if TYPEP
(fcn->storage_as.closure.code, tc_subr_2)
{
STACK_CHECK (&fcn);
INTERRUPT_CHECK ();
return (SUBR2 (fcn->storage_as.closure.code)
(fcn->storage_as.closure.env, a1));
}
default:
return (lapply (fcn, cons (a1, NIL)));
}
}
LISP
funcall2 (LISP fcn, LISP a1, LISP a2)
{
switch TYPE
(fcn)
{
case tc_subr_2:
case tc_subr_2n:
STACK_CHECK (&fcn);
INTERRUPT_CHECK ();
return (SUBR2 (fcn) (a1, a2));
default:
return (lapply (fcn, cons (a1, cons (a2, NIL))));
}
}
LISP
lqsort (LISP l, LISP f, LISP g)
/* this is a stupid recursive qsort */
{
int j, n;
LISP v, mark, less, notless;
for (v = l, n = 0; CONSP (v); v = CDR (v), ++n)
INTERRUPT_CHECK ();
if NNULLP
(v) my_err ("bad list to qsort", l);
if (n == 0)
return (NIL);
j = rand () % n;
for (v = l, n = 0; n < j; ++n)
v = CDR (v);
mark = CAR (v);
for (less = NIL, notless = NIL, v = l, n = 0; NNULLP (v); v = CDR (v), ++n)
if (j != n)
{
if NNULLP
(funcall2 (f,
NULLP (g) ? CAR (v) : funcall1 (g, CAR (v)),
NULLP (g) ? mark : funcall1 (g, mark)))
less = cons (CAR (v), less);
else
notless = cons (CAR (v), notless);
}
return (nconc (lqsort (less, f, g),
cons (mark,
lqsort (notless, f, g))));
}
LISP
string_lessp (LISP s1, LISP s2)
{
if (strcmp (get_c_string (s1), get_c_string (s2)) < 0)
return (sym_t);
else
return (NIL);
}
LISP
benchmark_funcall1 (LISP ln, LISP f, LISP a1)
{
long j, n;
LISP value = NIL;
n = get_c_long (ln);
for (j = 0; j < n; ++j)
value = funcall1 (f, a1);
return (value);
}
LISP
benchmark_funcall2 (LISP l)
{
long j, n;
LISP ln = car (l);
LISP f = car (cdr (l));
LISP a1 = car (cdr (cdr (l)));
LISP a2 = car (cdr (cdr (cdr (l))));
LISP value = NULL;
n = get_c_long (ln);
for (j = 0; j < n; ++j)
value = funcall2 (f, a1, a2);
return (value);
}
LISP
benchmark_eval (LISP ln, LISP exp, LISP env)
{
long j, n;
LISP value = NIL;
n = get_c_long (ln);
for (j = 0; j < n; ++j)
value = leval (exp, env);
return (value);
}
LISP
mapcar1 (LISP fcn, LISP in)
{
LISP res, ptr, l;
if NULLP
(in) return (NIL);
res = ptr = cons (funcall1 (fcn, car (in)), NIL);
for (l = cdr (in); CONSP (l); l = CDR (l))
ptr = CDR (ptr) = cons (funcall1 (fcn, CAR (l)), CDR (ptr));
return (res);
}
LISP
mapcar2 (LISP fcn, LISP in1, LISP in2)
{
LISP res, ptr, l1, l2;
if (NULLP (in1) || NULLP (in2))
return (NIL);
res = ptr = cons (funcall2 (fcn, car (in1), car (in2)), NIL);
for (l1 = cdr (in1), l2 = cdr (in2); CONSP (l1) && CONSP (l2); l1 = CDR (l1), l2 = CDR (l2))
ptr = CDR (ptr) = cons (funcall2 (fcn, CAR (l1), CAR (l2)), CDR (ptr));
return (res);
}
LISP
mapcar (LISP l)
{
LISP fcn = car (l);
switch (get_c_long (llength (l)))
{
case 2:
return (mapcar1 (fcn, car (cdr (l))));
case 3:
return (mapcar2 (fcn, car (cdr (l)), car (cdr (cdr (l)))));
default:
return (my_err ("mapcar case not handled", l));
}
}
LISP
lfmod (LISP x, LISP y)
{
if NFLONUMP
(x) my_err ("wta(1st) to fmod", x);
if NFLONUMP
(y) my_err ("wta(2nd) to fmod", y);
return (flocons (fmod (FLONM (x), FLONM (y))));
}
LISP
lsubset (LISP fcn, LISP l)
{
LISP result = NIL, v;
for (v = l; CONSP (v); v = CDR (v))
if NNULLP
(funcall1 (fcn, CAR (v)))
result = cons (CAR (v), result);
return (nreverse (result));
}
LISP
ass (LISP x, LISP alist, LISP fcn)
{
LISP l, tmp;
for (l = alist; CONSP (l); l = CDR (l))
{
tmp = CAR (l);
if (CONSP (tmp) && NNULLP (funcall2 (fcn, CAR (tmp), x)))
return (tmp);
INTERRUPT_CHECK ();
}
if EQ
(l, NIL) return (NIL);
return (my_err ("improper list to ass", alist));
}
LISP
append2 (LISP l1, LISP l2)
{
long n;
LISP result = NIL, p1, p2;
n = nlength (l1) + nlength (l2);
while (n > 0)
{
result = cons (NIL, result);
--n;
}
for (p1 = result, p2 = l1; NNULLP (p2); p1 = cdr (p1), p2 = cdr (p2))
setcar (p1, car (p2));
for (p2 = l2; NNULLP (p2); p1 = cdr (p1), p2 = cdr (p2))
setcar (p1, car (p2));
return (result);
}
LISP
append (LISP l)
{
STACK_CHECK (&l);
INTERRUPT_CHECK ();
if NULLP
(l)
return (NIL);
else if NULLP
(cdr (l))
return (car (l));
else if NULLP
(cddr (l))
return (append2 (car (l), cadr (l)));
else
return (append2 (car (l), append (cdr (l))));
}
LISP
listn (long n,...)
{
LISP result, ptr;
long j;
va_list args;
for (j = 0, result = NIL; j < n; ++j)
result = cons (NIL, result);
va_start (args, n);
for (j = 0, ptr = result; j < n; ptr = cdr (ptr), ++j)
setcar (ptr, va_arg (args, LISP));
va_end (args);
return (result);
}
LISP
fast_load (LISP lfname, LISP noeval)
{
char *fname;
LISP stream;
LISP result = NIL, form;
fname = get_c_string (lfname);
if (siod_verbose_level >= 3)
{
put_st ("fast loading ");
put_st (fname);
put_st ("\n");
}
stream = listn (3,
fopen_c (fname, "rb"),
cons_array (flocons (100), NIL),
flocons (0));
while (NEQ (stream, form = fast_read (stream)))
{
if (siod_verbose_level >= 5)
lprint (form, NIL);
if NULLP
(noeval)
leval (form, NIL);
else
result = cons (form, result);
}
fclose_l (car (stream));
if (siod_verbose_level >= 3)
put_st ("done.\n");
return (nreverse (result));
}
static void
shexstr (char *outstr, void *buff, size_t len)
{
unsigned char *data = buff;
size_t j;
for (j = 0; j < len; ++j)
sprintf (&outstr[j * 2], "%02X", data[j]);
}
LISP
fast_save (LISP fname, LISP forms, LISP nohash, LISP comment)
{
char *cname, msgbuff[100], databuff[50];
LISP stream, l;
FILE *f;
long l_one = 1;
double d_one = 1.0;
cname = get_c_string (fname);
if (siod_verbose_level >= 3)
{
put_st ("fast saving forms to ");
put_st (cname);
put_st ("\n");
}
stream = listn (3,
fopen_c (cname, "wb"),
NNULLP (nohash) ? NIL : cons_array (flocons (100), NIL),
flocons (0));
f = get_c_file (car (stream), NULL);
if NNULLP
(comment)
fput_st (f, get_c_string (comment));
sprintf (msgbuff, "# Siod Binary Object Save File\n");
fput_st (f, msgbuff);
sprintf (msgbuff, "# sizeof(long) = %d\n# sizeof(double) = %d\n",
sizeof (long), sizeof (double));
fput_st (f, msgbuff);
shexstr (databuff, &l_one, sizeof (l_one));
sprintf (msgbuff, "# 1 = %s\n", databuff);
fput_st (f, msgbuff);
shexstr (databuff, &d_one, sizeof (d_one));
sprintf (msgbuff, "# 1.0 = %s\n", databuff);
fput_st (f, msgbuff);
for (l = forms; NNULLP (l); l = cdr (l))
fast_print (car (l), stream);
fclose_l (car (stream));
if (siod_verbose_level >= 3)
put_st ("done.\n");
return (NIL);
}
void
swrite1 (LISP stream, LISP data)
{
FILE *f = get_c_file (stream, stdout);
switch TYPE
(data)
{
case tc_symbol:
case tc_string:
fput_st (f, get_c_string (data));
break;
default:
lprin1f (data, f);
break;
}
}
LISP
swrite (LISP stream, LISP table, LISP data)
{
LISP value, key;
long j, k, m, n;
switch (TYPE (data))
{
case tc_symbol:
value = href (table, data);
if CONSP
(value)
{
swrite1 (stream, CAR (value));
if NNULLP
(CDR (value))
hset (table, data, CDR (value));
}
else
swrite1 (stream, value);
break;
case tc_lisp_array:
n = data->storage_as.lisp_array.dim;
if (n < 1)
my_err ("no object repeat count", data);
key = data->storage_as.lisp_array.data[0];
if NULLP
(value = href (table, key))
value = key;
else if CONSP
(value)
{
if NNULLP
(CDR (value))
hset (table, key, CDR (value));
value = CAR (value);
}
m = get_c_long (value);
for (k = 0; k < m; ++k)
for (j = 1; j < n; ++j)
swrite (stream, table, data->storage_as.lisp_array.data[j]);
break;
case tc_cons:
/* this should be handled similar to the array case */
default:
swrite1 (stream, data);
}
return (NIL);
}
LISP
lpow (LISP x, LISP y)
{
if NFLONUMP
(x) my_err ("wta(1st) to pow", x);
if NFLONUMP
(y) my_err ("wta(2nd) to pow", y);
return (flocons (pow (FLONM (x), FLONM (y))));
}
LISP
lexp (LISP x)
{
return (flocons (exp (get_c_double (x))));
}
LISP
llog (LISP x)
{
return (flocons (log (get_c_double (x))));
}
LISP
lsin (LISP x)
{
return (flocons (sin (get_c_double (x))));
}
LISP
lcos (LISP x)
{
return (flocons (cos (get_c_double (x))));
}
LISP
ltan (LISP x)
{
return (flocons (tan (get_c_double (x))));
}
LISP
lasin (LISP x)
{
return (flocons (asin (get_c_double (x))));
}
LISP
lacos (LISP x)
{
return (flocons (acos (get_c_double (x))));
}
LISP
latan (LISP x)
{
return (flocons (atan (get_c_double (x))));
}
LISP
latan2 (LISP x, LISP y)
{
return (flocons (atan2 (get_c_double (x), get_c_double (y))));
}
LISP
hexstr (LISP a)
{
unsigned char *in;
char *out;
LISP result;
long j, dim;
in = (unsigned char *) get_c_string_dim (a, &dim);
result = strcons (dim * 2, NULL);
for (out = get_c_string (result), j = 0; j < dim; ++j, out += 2)
sprintf (out, "%02x", in[j]);
return (result);
}
static int
xdigitvalue (int c)
{
if (isdigit (c))
return (c - '0');
if (isxdigit (c))
return (toupper (c) - 'A' + 10);
return (0);
}
LISP
hexstr2bytes (LISP a)
{
char *in;
unsigned char *out;
LISP result;
long j, dim;
in = get_c_string (a);
dim = strlen (in) / 2;
result = arcons (tc_byte_array, dim, 0);
out = (unsigned char *) result->storage_as.string.data;
for (j = 0; j < dim; ++j)
out[j] = xdigitvalue (in[j * 2]) * 16 + xdigitvalue (in[j * 2 + 1]);
return (result);
}
LISP
getprop (LISP plist, LISP key)
{
LISP l;
for (l = cdr (plist); NNULLP (l); l = cddr (l))
if EQ
(car (l), key)
return (cadr (l));
else
INTERRUPT_CHECK ();
return (NIL);
}
LISP
setprop (LISP plist, LISP key, LISP value)
{
my_err ("not implemented", NIL);
return (NIL);
}
LISP
putprop (LISP plist, LISP value, LISP key)
{
return (setprop (plist, key, value));
}
LISP
ltypeof (LISP obj)
{
long x;
x = TYPE (obj);
switch (x)
{
case tc_nil:
return (cintern ("tc_nil"));
case tc_cons:
return (cintern ("tc_cons"));
case tc_flonum:
return (cintern ("tc_flonum"));
case tc_symbol:
return (cintern ("tc_symbol"));
case tc_subr_0:
return (cintern ("tc_subr_0"));
case tc_subr_1:
return (cintern ("tc_subr_1"));
case tc_subr_2:
return (cintern ("tc_subr_2"));
case tc_subr_2n:
return (cintern ("tc_subr_2n"));
case tc_subr_3:
return (cintern ("tc_subr_3"));
case tc_subr_4:
return (cintern ("tc_subr_4"));
case tc_subr_5:
return (cintern ("tc_subr_5"));
case tc_lsubr:
return (cintern ("tc_lsubr"));
case tc_fsubr:
return (cintern ("tc_fsubr"));
case tc_msubr:
return (cintern ("tc_msubr"));
case tc_closure:
return (cintern ("tc_closure"));
case tc_free_cell:
return (cintern ("tc_free_cell"));
case tc_string:
return (cintern ("tc_string"));
case tc_byte_array:
return (cintern ("tc_byte_array"));
case tc_double_array:
return (cintern ("tc_double_array"));
case tc_long_array:
return (cintern ("tc_long_array"));
case tc_lisp_array:
return (cintern ("tc_lisp_array"));
case tc_c_file:
return (cintern ("tc_c_file"));
default:
return (flocons (x));
}
}
LISP
caaar (LISP x)
{
return (car (car (car (x))));
}
LISP
caadr (LISP x)
{
return (car (car (cdr (x))));
}
LISP
cadar (LISP x)
{
return (car (cdr (car (x))));
}
LISP
caddr (LISP x)
{
return (car (cdr (cdr (x))));
}
LISP
cdaar (LISP x)
{
return (cdr (car (car (x))));
}
LISP
cdadr (LISP x)
{
return (cdr (car (cdr (x))));
}
LISP
cddar (LISP x)
{
return (cdr (cdr (car (x))));
}
LISP
cdddr (LISP x)
{
return (cdr (cdr (cdr (x))));
}
LISP
ash (LISP value, LISP n)
{
long m, k;
m = get_c_long (value);
k = get_c_long (n);
if (k > 0)
m = m << k;
else
m = m >> (-k);
return (flocons (m));
}
LISP
bitand (LISP a, LISP b)
{
return (flocons (get_c_long (a) & get_c_long (b)));
}
LISP
bitor (LISP a, LISP b)
{
return (flocons (get_c_long (a) | get_c_long (b)));
}
LISP
bitxor (LISP a, LISP b)
{
return (flocons (get_c_long (a) ^ get_c_long (b)));
}
LISP
bitnot (LISP a)
{
return (flocons (~get_c_long (a)));
}
LISP
leval_prog1 (LISP args, LISP env)
{
LISP retval, l;
retval = leval (car (args), env);
for (l = cdr (args); NNULLP (l); l = cdr (l))
leval (car (l), env);
return (retval);
}
LISP
leval_cond (LISP * pform, LISP * penv)
{
LISP args, env, clause, value, next;
args = cdr (*pform);
env = *penv;
if NULLP
(args)
{
*pform = NIL;
return (NIL);
}
next = cdr (args);
while NNULLP
(next)
{
clause = car (args);
value = leval (car (clause), env);
if NNULLP
(value)
{
clause = cdr (clause);
if NULLP
(clause)
{
*pform = value;
return (NIL);
}
else
{
next = cdr (clause);
while (NNULLP (next))
{
leval (car (clause), env);
clause = next;
next = cdr (next);
}
*pform = car (clause);
return (sym_t);
}
}
args = next;
next = cdr (next);
}
clause = car (args);
next = cdr (clause);
if NULLP
(next)
{
*pform = car (clause);
return (sym_t);
}
value = leval (car (clause), env);
if NULLP
(value)
{
*pform = NIL;
return (NIL);
}
clause = next;
next = cdr (next);
while (NNULLP (next))
{
leval (car (clause), env);
clause = next;
next = cdr (next);
}
*pform = car (clause);
return (sym_t);
}
LISP
lstrspn (LISP str1, LISP str2)
{
return (flocons (strspn (get_c_string (str1), get_c_string (str2))));
}
LISP
lstrcspn (LISP str1, LISP str2)
{
return (flocons (strcspn (get_c_string (str1), get_c_string (str2))));
}
LISP
substring_equal (LISP str1, LISP str2, LISP start, LISP end)
{
char *cstr1, *cstr2;
long len1, n, s, e;
cstr1 = get_c_string_dim (str1, &len1);
cstr2 = get_c_string_dim (str2, &n);
s = NULLP (start) ? 0 : get_c_long (start);
e = NULLP (end) ? n : get_c_long (end);
if ((s < 0) || (s > e) || (e < 0) || (e > n) || ((e - s) != len1))
return (NIL);
return ((memcmp (cstr1, &cstr2[s], e - s) == 0) ? a_true_value () : NIL);
}
LISP
set_eval_history (LISP len, LISP circ)
{
LISP data;
data = NULLP (len) ? len : make_list (len, NIL);
if NNULLP
(circ)
data = nconc (data, data);
setvar (cintern ("*eval-history-ptr*"), data, NIL);
setvar (cintern ("*eval-history*"), data, NIL);
return (len);
}
static LISP
parser_fasl (LISP ignore)
{
return (closure (listn (3,
NIL,
cons_array (flocons (100), NIL),
flocons (0)),
leval (cintern ("parser_fasl_hook"), NIL)));
}
static LISP
parser_fasl_hook (LISP env, LISP f)
{
LISP result;
setcar (env, f);
result = fast_read (env);
if EQ
(result, env)
return (get_eof_val ());
else
return (result);
}
void
init_subrs_a (void)
{
init_subr_2 ("aref", aref1);
init_subr_3 ("aset", aset1);
init_lsubr ("string-append", string_append);
init_lsubr ("bytes-append", bytes_append);
init_subr_1 ("string-length", string_length);
init_subr_1 ("string-dimension", string_dim);
init_subr_1 ("read-from-string", read_from_string);
init_subr_3 ("print-to-string", print_to_string);
init_subr_2 ("cons-array", cons_array);
init_subr_2 ("sxhash", sxhash);
init_subr_2 ("equal?", equal);
init_subr_2 ("href", href);
init_subr_3 ("hset", hset);
init_subr_2 ("assoc", assoc);
init_subr_2 ("assv", assv);
init_subr_1 ("fast-read", fast_read);
init_subr_2 ("fast-print", fast_print);
init_subr_2 ("make-list", make_list);
init_subr_2 ("fread", lfread);
init_subr_2 ("fwrite", lfwrite);
init_subr_1 ("fflush", lfflush);
init_subr_1 ("length", llength);
init_subr_4 ("number->string", number2string);
init_subr_2 ("string->number", string2number);
init_subr_3 ("substring", substring);
init_subr_2 ("string-search", string_search);
init_subr_1 ("string-trim", string_trim);
init_subr_1 ("string-trim-left", string_trim_left);
init_subr_1 ("string-trim-right", string_trim_right);
init_subr_1 ("string-upcase", string_upcase);
init_subr_1 ("string-downcase", string_downcase);
init_subr_2 ("strcmp", lstrcmp);
init_subr_2 ("strcat", lstrcat);
init_subr_2 ("strcpy", lstrcpy);
init_subr_2 ("strbreakup", lstrbreakup);
init_subr_2 ("unbreakupstr", lstrunbreakup);
init_subr_1 ("string?", stringp);
gc_protect_sym (&sym_e, "e");
gc_protect_sym (&sym_f, "f");
gc_protect_sym (&sym_plists, "*plists*");
setvar (sym_plists, arcons (tc_lisp_array, 100, 1), NIL);
init_subr_3 ("lref-default", lref_default);
init_subr_3 ("larg-default", larg_default);
init_subr_3 ("lkey-default", lkey_default);
init_lsubr ("list", llist);
init_lsubr ("writes", writes);
init_subr_3 ("qsort", lqsort);
init_subr_2 ("string-lessp", string_lessp);
init_lsubr ("mapcar", mapcar);
init_subr_3 ("mapcar2", mapcar2);
init_subr_2 ("mapcar1", mapcar1);
init_subr_3 ("benchmark-funcall1", benchmark_funcall1);
init_lsubr ("benchmark-funcall2", benchmark_funcall2);
init_subr_3 ("benchmark-eval", benchmark_eval);
init_subr_2 ("fmod", lfmod);
init_subr_2 ("subset", lsubset);
init_subr_1 ("base64encode", base64encode);
init_subr_1 ("base64decode", base64decode);
init_subr_3 ("ass", ass);
init_subr_2 ("append2", append2);
init_lsubr ("append", append);
init_subr_4 ("fast-save", fast_save);
init_subr_2 ("fast-load", fast_load);
init_subr_3 ("swrite", swrite);
init_subr_2 ("pow", lpow);
init_subr_1 ("exp", lexp);
init_subr_1 ("log", llog);
init_subr_1 ("sin", lsin);
init_subr_1 ("cos", lcos);
init_subr_1 ("tan", ltan);
init_subr_1 ("asin", lasin);
init_subr_1 ("acos", lacos);
init_subr_1 ("atan", latan);
init_subr_2 ("atan2", latan2);
init_subr_1 ("typeof", ltypeof);
init_subr_1 ("caaar", caaar);
init_subr_1 ("caadr", caadr);
init_subr_1 ("cadar", cadar);
init_subr_1 ("caddr", caddr);
init_subr_1 ("cdaar", cdaar);
init_subr_1 ("cdadr", cdadr);
init_subr_1 ("cddar", cddar);
init_subr_1 ("cdddr", cdddr);
setvar (cintern ("*pi*"), flocons (atan (1.0) * 4), NIL);
init_base64_table ();
init_subr_1 ("array->hexstr", hexstr);
init_subr_1 ("hexstr->bytes", hexstr2bytes);
init_subr_3 ("ass", ass);
init_subr_2 ("bit-and", bitand);
init_subr_2 ("bit-or", bitor);
init_subr_2 ("bit-xor", bitxor);
init_subr_1 ("bit-not", bitnot);
init_msubr ("cond", leval_cond);
init_fsubr ("prog1", leval_prog1);
init_subr_2 ("strspn", lstrspn);
init_subr_2 ("strcspn", lstrcspn);
init_subr_4 ("substring-equal?", substring_equal);
init_subr_1 ("butlast", butlast);
init_subr_2 ("ash", ash);
init_subr_2 ("get", getprop);
init_subr_3 ("setprop", setprop);
init_subr_3 ("putprop", putprop);
init_subr_1 ("last", last);
init_subr_2 ("memq", memq);
init_subr_2 ("memv", memv);
init_subr_2 ("member", member);
init_subr_2 ("nth", nth);
init_subr_2 ("nconc", nconc);
init_subr_2 ("set-eval-history", set_eval_history);
init_subr_1 ("parser_fasl", parser_fasl);
setvar (cintern ("*parser_fasl.scm-loaded*"), a_true_value (), NIL);
init_subr_2 ("parser_fasl_hook", parser_fasl_hook);
init_sliba_version ();
}
Reference in New Issue View Git Blame Copy Permalink