4
* COPYRIGHT (c) 1988-1994 BY *
5
* PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
6
* See the source file SLIB.C for more information. *
8
Array-hacking code moved to another source file.
25
init_sliba_version (void)
27
setvar (cintern ("*sliba-version*"),
28
cintern ("$Id: sliba.c,v 1.14 2004/08/08 19:59:16 neo Exp $"),
32
static LISP sym_plists = NIL;
33
static LISP bashnum = NIL;
34
static LISP sym_e = NIL;
35
static LISP sym_f = NIL;
38
init_storage_a1 (long type)
41
struct user_type_hooks *p;
48
set_print_hooks (type, array_prin1);
49
p = get_user_type_hooks (type);
50
p->fast_print = array_fast_print;
51
p->fast_read = array_fast_read;
52
p->equal = array_equal;
53
p->c_sxhash = array_sxhash;
59
gc_protect (&bashnum);
60
bashnum = newcell (tc_flonum);
61
init_storage_a1 (tc_string);
62
init_storage_a1 (tc_double_array);
63
init_storage_a1 (tc_long_array);
64
init_storage_a1 (tc_lisp_array);
65
init_storage_a1 (tc_byte_array);
69
array_gc_relocate (LISP ptr)
72
if ((nw = heap) >= heap_end)
75
memcpy (nw, ptr, sizeof (struct obj));
80
array_gc_scan (LISP ptr)
85
for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
86
ptr->storage_as.lisp_array.data[j] =
87
gc_relocate (ptr->storage_as.lisp_array.data[j]);
91
array_gc_mark (LISP ptr)
96
for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
97
gc_mark (ptr->storage_as.lisp_array.data[j]);
102
array_gc_free (LISP ptr)
108
free (ptr->storage_as.string.data);
110
case tc_double_array:
111
free (ptr->storage_as.double_array.data);
114
free (ptr->storage_as.long_array.data);
117
free (ptr->storage_as.lisp_array.data);
123
array_prin1 (LISP ptr, struct gen_printio *f)
130
if (strcspn (ptr->storage_as.string.data, "\"\\\n\r\t") ==
131
strlen (ptr->storage_as.string.data))
132
gput_st (f, ptr->storage_as.string.data);
137
n = strlen (ptr->storage_as.string.data);
138
for (j = 0; j < n; ++j)
139
switch (c = ptr->storage_as.string.data[j])
166
case tc_double_array:
168
for (j = 0; j < ptr->storage_as.double_array.dim; ++j)
170
g_ascii_formatd (tkbuffer, TKBUFFERN, "%g",
171
ptr->storage_as.double_array.data[j]);
172
gput_st (f, tkbuffer);
173
if ((j + 1) < ptr->storage_as.double_array.dim)
180
for (j = 0; j < ptr->storage_as.long_array.dim; ++j)
182
sprintf (tkbuffer, "%ld", ptr->storage_as.long_array.data[j]);
183
gput_st (f, tkbuffer);
184
if ((j + 1) < ptr->storage_as.long_array.dim)
189
sprintf (tkbuffer, "#%ld\"", ptr->storage_as.string.dim);
190
gput_st (f, tkbuffer);
191
for (j = 0, i = 0; j < ptr->storage_as.string.dim; j++)
193
sprintf (tkbuffer + i, "%02x",
194
ptr->storage_as.string.data[j] & 0xFF);
196
if (i % TKBUFFERN == 0)
198
gput_st (f, tkbuffer);
203
gput_st (f, tkbuffer);
208
for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
210
lprin1g (ptr->storage_as.lisp_array.data[j], f);
211
if ((j + 1) < ptr->storage_as.lisp_array.dim)
220
strcons (long length, char *data)
224
flag = no_interrupt (1);
228
length = strlen (data);
229
s->storage_as.string.data = must_malloc (length + 1);
230
s->storage_as.string.dim = length;
232
memcpy (s->storage_as.string.data, data, length);
233
s->storage_as.string.data[length] = 0;
239
rfs_getc (unsigned char **p)
250
rfs_ungetc (unsigned char c, unsigned char **p)
256
read_from_string (LISP x)
260
p = get_c_string (x);
261
s.getc_fcn = (int (*)(void *)) rfs_getc;
262
s.ungetc_fcn = (void (*)(int, void *)) rfs_ungetc;
263
s.cb_argument = (char *) &p;
264
return (readtl (&s));
268
pts_puts (char *from, void *cb)
271
size_t fromlen, intolen, intosize, fitsize;
273
fromlen = strlen (from);
274
intolen = strlen (into->storage_as.string.data);
275
intosize = into->storage_as.string.dim - intolen;
276
fitsize = (fromlen < intosize) ? fromlen : intosize;
277
memcpy (&into->storage_as.string.data[intolen], from, fitsize);
278
into->storage_as.string.data[intolen + fitsize] = 0;
279
if (fitsize < fromlen)
280
my_err ("print to string overflow", NIL);
285
err_wta_str (LISP exp)
287
return (my_err ("not a string", exp));
291
print_to_string (LISP exp, LISP str, LISP nostart)
293
struct gen_printio s;
295
(str, tc_string) err_wta_str (str);
297
s.puts_fcn = pts_puts;
301
str->storage_as.string.data[0] = 0;
307
aref1 (LISP a, LISP i)
311
(i) my_err ("bad index to aref", i);
312
k = (long) FLONM (i);
314
my_err ("negative index to aref", i);
320
if (k >= a->storage_as.string.dim)
321
my_err ("index too large", i);
322
return (flocons ((double) a->storage_as.string.data[k]));
323
case tc_double_array:
324
if (k >= a->storage_as.double_array.dim)
325
my_err ("index too large", i);
326
return (flocons (a->storage_as.double_array.data[k]));
328
if (k >= a->storage_as.long_array.dim)
329
my_err ("index too large", i);
330
return (flocons (a->storage_as.long_array.data[k]));
332
if (k >= a->storage_as.lisp_array.dim)
333
my_err ("index too large", i);
334
return (a->storage_as.lisp_array.data[k]);
336
return (my_err ("invalid argument to aref", a));
343
my_err ("index to aset too large", i);
349
my_err ("bad value to store in array", v);
353
aset1 (LISP a, LISP i, LISP v)
357
(i) my_err ("bad index to aset", i);
358
k = (long) FLONM (i);
360
my_err ("negative index to aset", i);
368
if (k >= a->storage_as.string.dim)
370
a->storage_as.string.data[k] = (char) FLONM (v);
372
case tc_double_array:
375
if (k >= a->storage_as.double_array.dim)
377
a->storage_as.double_array.data[k] = FLONM (v);
382
if (k >= a->storage_as.long_array.dim)
384
a->storage_as.long_array.data[k] = (long) FLONM (v);
387
if (k >= a->storage_as.lisp_array.dim)
389
a->storage_as.lisp_array.data[k] = v;
392
return (my_err ("invalid argument to aset", a));
397
arcons (long typecode, long n, long initp)
401
flag = no_interrupt (1);
405
case tc_double_array:
406
a->storage_as.double_array.dim = n;
407
a->storage_as.double_array.data = (double *) must_malloc (n *
410
for (j = 0; j < n; ++j)
411
a->storage_as.double_array.data[j] = 0.0;
414
a->storage_as.long_array.dim = n;
415
a->storage_as.long_array.data = (long *) must_malloc (n * sizeof (long));
417
for (j = 0; j < n; ++j)
418
a->storage_as.long_array.data[j] = 0;
421
a->storage_as.string.dim = n;
422
a->storage_as.string.data = (char *) must_malloc (n + 1);
423
a->storage_as.string.data[n] = 0;
425
for (j = 0; j < n; ++j)
426
a->storage_as.string.data[j] = ' ';
428
a->storage_as.string.dim = n;
429
a->storage_as.string.data = (char *) must_malloc (n);
431
for (j = 0; j < n; ++j)
432
a->storage_as.string.data[j] = 0;
435
a->storage_as.lisp_array.dim = n;
436
a->storage_as.lisp_array.data = (LISP *) must_malloc (n * sizeof (LISP));
437
for (j = 0; j < n; ++j)
438
a->storage_as.lisp_array.data[j] = NIL;
449
mallocl (void *place, long size)
453
n = size / sizeof (long);
454
r = size % sizeof (long);
457
retval = arcons (tc_long_array, n, 0);
458
*(long **) place = retval->storage_as.long_array.data;
463
cons_array (LISP dim, LISP kind)
467
if (NFLONUMP (dim) || (FLONM (dim) < 0))
468
return (my_err ("bad dimension to cons-array", dim));
470
n = (long) FLONM (dim);
471
flag = no_interrupt (1);
474
(cintern ("double"), kind)
476
a->type = tc_double_array;
477
a->storage_as.double_array.dim = n;
478
a->storage_as.double_array.data = (double *) must_malloc (n *
480
for (j = 0; j < n; ++j)
481
a->storage_as.double_array.data[j] = 0.0;
484
(cintern ("long"), kind)
486
a->type = tc_long_array;
487
a->storage_as.long_array.dim = n;
488
a->storage_as.long_array.data = (long *) must_malloc (n * sizeof (long));
489
for (j = 0; j < n; ++j)
490
a->storage_as.long_array.data[j] = 0;
493
(cintern ("string"), kind)
496
a->storage_as.string.dim = n;
497
a->storage_as.string.data = (char *) must_malloc (n + 1);
498
a->storage_as.string.data[n] = 0;
499
for (j = 0; j < n; ++j)
500
a->storage_as.string.data[j] = ' ';
503
(cintern ("byte"), kind)
505
a->type = tc_byte_array;
506
a->storage_as.string.dim = n;
507
a->storage_as.string.data = (char *) must_malloc (n);
508
for (j = 0; j < n; ++j)
509
a->storage_as.string.data[j] = 0;
511
else if (EQ (cintern ("lisp"), kind) || NULLP (kind))
513
a->type = tc_lisp_array;
514
a->storage_as.lisp_array.dim = n;
515
a->storage_as.lisp_array.data = (LISP *) must_malloc (n * sizeof (LISP));
516
for (j = 0; j < n; ++j)
517
a->storage_as.lisp_array.data[j] = NIL;
520
my_err ("bad type of array", kind);
526
string_append (LISP args)
532
for (l = args; NNULLP (l); l = cdr (l))
533
size += strlen (get_c_string (car (l)));
534
s = strcons (size, NULL);
535
data = s->storage_as.string.data;
537
for (l = args; NNULLP (l); l = cdr (l))
538
strcat (data, get_c_string (car (l)));
543
bytes_append (LISP args)
549
for (l = args; NNULLP (l); l = cdr (l))
551
get_c_string_dim (car (l), &n);
554
s = arcons (tc_byte_array, size, 0);
555
data = s->storage_as.string.data;
556
for (j = 0, l = args; NNULLP (l); l = cdr (l))
558
ptr = get_c_string_dim (car (l), &n);
559
memcpy (&data[j], ptr, n);
566
substring (LISP str, LISP start, LISP end)
570
data = get_c_string_dim (str, &n);
571
s = get_c_long (start);
576
e = get_c_long (end);
577
if ((s < 0) || (s > e))
578
my_err ("bad start index", start);
579
if ((e < 0) || (e > n))
580
my_err ("bad end index", end);
581
return (strcons (e - s, &data[s]));
585
string_search (LISP token, LISP str)
588
s1 = get_c_string (str);
589
s2 = get_c_string (token);
590
ptr = strstr (s1, s2);
592
return (flocons (ptr - s1));
597
#define IS_TRIM_SPACE(_x) (strchr(" \t\r\n",(_x)))
600
string_trim (LISP str)
602
char *start, *end; /*, *sp = " \t\r\n";*/
603
start = get_c_string (str);
604
while (*start && IS_TRIM_SPACE (*start))
606
end = &start[strlen (start)];
607
while ((end > start) && IS_TRIM_SPACE (*(end - 1)))
609
return (strcons (end - start, start));
613
string_trim_left (LISP str)
616
start = get_c_string (str);
617
while (*start && IS_TRIM_SPACE (*start))
619
end = &start[strlen (start)];
620
return (strcons (end - start, start));
624
string_trim_right (LISP str)
627
start = get_c_string (str);
628
end = &start[strlen (start)];
629
while ((end > start) && IS_TRIM_SPACE (*(end - 1)))
631
return (strcons (end - start, start));
635
string_upcase (LISP str)
640
s1 = get_c_string (str);
642
result = strcons (n, s1);
643
s2 = get_c_string (result);
644
for (j = 0; j < n; ++j)
645
s2[j] = g_ascii_toupper (s2[j]);
650
string_downcase (LISP str)
655
s1 = get_c_string (str);
657
result = strcons (n, s1);
658
s2 = get_c_string (result);
659
for (j = 0; j < n; ++j)
660
s2[j] = g_ascii_tolower (s2[j]);
665
lreadstring (struct gen_readio * f)
667
int j, c, n, ndigits;
671
while (((c = GETC_FCN (f)) != '"') && (c != EOF))
677
my_err ("eof after \\", NIL);
715
my_err ("eof after \\0", NIL);
716
if (c >= '0' && c <= '7')
730
if ((j + 1) >= TKBUFFERN)
731
my_err ("read string overflow", NIL);
736
return (strcons (j, tkbuffer));
741
lreadsharp (struct gen_readio * f)
753
result = arcons (tc_lisp_array, n, 1);
754
for (l = obj, j = 0; j < n; l = cdr (l), ++j)
755
result->storage_as.lisp_array.data[j] = car (l);
759
return (leval (obj, NIL));
763
return (flocons (1));
765
return (my_err ("readsharp syntax not handled", NIL));
769
#define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod))
772
c_sxhash (LISP obj, long n)
777
struct user_type_hooks *p;
786
hash = c_sxhash (CAR (obj), n);
787
for (tmp = CDR (obj); CONSP (tmp); tmp = CDR (tmp))
788
hash = HASH_COMBINE (hash, c_sxhash (CAR (tmp), n), n);
789
hash = HASH_COMBINE (hash, c_sxhash (tmp, n), n);
792
for (hash = 0, s = (unsigned char *) PNAME (obj); *s; ++s)
793
hash = HASH_COMBINE (hash, *s, n);
804
for (hash = 0, s = (unsigned char *) obj->storage_as.subr.name; *s; ++s)
805
hash = HASH_COMBINE (hash, *s, n);
808
return (((unsigned long) FLONM (obj)) % n);
810
p = get_user_type_hooks (TYPE (obj));
812
return ((*p->c_sxhash) (obj, n));
819
sxhash (LISP obj, LISP n)
821
return (flocons (c_sxhash (obj, FLONUMP (n) ? (long) FLONM (n) : 10000)));
825
equal (LISP a, LISP b)
827
struct user_type_hooks *p;
833
(a, b) return (sym_t);
835
if (atype != TYPE (b))
841
(equal (car (a), car (b))) return (NIL);
846
return ((FLONM (a) == FLONM (b)) ? sym_t : NIL);
850
p = get_user_type_hooks (atype);
852
return ((*p->equal) (a, b));
859
array_equal (LISP a, LISP b)
866
len = a->storage_as.string.dim;
867
if (len != b->storage_as.string.dim)
869
if (memcmp (a->storage_as.string.data, b->storage_as.string.data, len) == 0)
874
len = a->storage_as.long_array.dim;
875
if (len != b->storage_as.long_array.dim)
877
if (memcmp (a->storage_as.long_array.data,
878
b->storage_as.long_array.data,
879
len * sizeof (long)) == 0)
883
case tc_double_array:
884
len = a->storage_as.double_array.dim;
885
if (len != b->storage_as.double_array.dim)
887
for (j = 0; j < len; ++j)
888
if (a->storage_as.double_array.data[j] !=
889
b->storage_as.double_array.data[j])
893
len = a->storage_as.lisp_array.dim;
894
if (len != b->storage_as.lisp_array.dim)
896
for (j = 0; j < len; ++j)
898
(equal (a->storage_as.lisp_array.data[j],
899
b->storage_as.lisp_array.data[j]))
903
return (errswitch ());
908
array_sxhash (LISP a, long n)
911
unsigned char *char_data;
912
unsigned long *long_data;
918
len = a->storage_as.string.dim;
919
for (j = 0, hash = 0, char_data = (unsigned char *) a->storage_as.string.data;
922
hash = HASH_COMBINE (hash, *char_data, n);
925
len = a->storage_as.long_array.dim;
926
for (j = 0, hash = 0, long_data = (unsigned long *) a->storage_as.long_array.data;
929
hash = HASH_COMBINE (hash, *long_data % n, n);
931
case tc_double_array:
932
len = a->storage_as.double_array.dim;
933
for (j = 0, hash = 0, double_data = a->storage_as.double_array.data;
936
hash = HASH_COMBINE (hash, (unsigned long) *double_data % n, n);
939
len = a->storage_as.lisp_array.dim;
940
for (j = 0, hash = 0; j < len; ++j)
941
hash = HASH_COMBINE (hash,
942
c_sxhash (a->storage_as.lisp_array.data[j], n),
952
href_index (LISP table, LISP key)
956
(table, tc_lisp_array) my_err ("not a hash table", table);
957
index = c_sxhash (key, table->storage_as.lisp_array.dim);
958
if ((index < 0) || (index >= table->storage_as.lisp_array.dim))
960
my_err ("sxhash inconsistency", table);
968
href (LISP table, LISP key)
970
return (cdr (assoc (key,
971
table->storage_as.lisp_array.data[href_index (table, key)])));
975
hset (LISP table, LISP key, LISP value)
979
index = href_index (table, key);
980
l = table->storage_as.lisp_array.data[index];
982
(cell = assoc (key, l))
983
return (setcdr (cell, value));
984
cell = cons (key, value);
985
table->storage_as.lisp_array.data[index] = cons (cell, l);
990
assoc (LISP x, LISP alist)
993
for (l = alist; CONSP (l); l = CDR (l))
996
if (CONSP (tmp) && equal (CAR (tmp), x))
1001
(l, NIL) return (NIL);
1002
return (my_err ("improper list to assoc", alist));
1006
assv (LISP x, LISP alist)
1009
for (l = alist; CONSP (l); l = CDR (l))
1012
if (CONSP (tmp) && NNULLP (eql (CAR (tmp), x)))
1017
(l, NIL) return (NIL);
1018
return (my_err ("improper list to assv", alist));
1022
put_long (long i, FILE * f)
1024
fwrite (&i, sizeof (long), 1, f);
1031
fread (&i, sizeof (long), 1, f);
1036
fast_print_table (LISP obj, LISP table)
1040
f = get_c_file (car (table), (FILE *) NULL);
1042
(ht = car (cdr (table)))
1044
index = href (ht, obj);
1049
put_long (get_c_long (index), f);
1053
(index = car (cdr (cdr (table))))
1055
hset (ht, obj, index);
1056
FLONM (bashnum) = 1.0;
1057
setcar (cdr (cdr (table)), plus (index, bashnum));
1059
put_long (get_c_long (index), f);
1064
fast_print (LISP obj, LISP table)
1069
struct user_type_hooks *p;
1071
f = get_c_file (car (table), (FILE *) NULL);
1078
for (len = 0, tmp = obj; CONSP (tmp); tmp = CDR (tmp))
1086
fast_print (car (obj), table);
1087
fast_print (cdr (obj), table);
1094
for (tmp = obj; CONSP (tmp); tmp = CDR (tmp))
1095
fast_print (CAR (tmp), table);
1101
for (tmp = obj; CONSP (tmp); tmp = CDR (tmp))
1102
fast_print (CAR (tmp), table);
1103
fast_print (tmp, table);
1107
putc (tc_flonum, f);
1108
fwrite (&obj->storage_as.flonum.data,
1109
sizeof (obj->storage_as.flonum.data),
1114
if (fast_print_table (obj, table))
1116
putc (tc_symbol, f);
1117
len = strlen (PNAME (obj));
1118
if (len >= TKBUFFERN)
1119
my_err ("symbol name too long", obj);
1121
fwrite (PNAME (obj), len, 1, f);
1127
p = get_user_type_hooks (TYPE (obj));
1129
return ((*p->fast_print) (obj, table));
1131
return (my_err ("cannot fast-print", obj));
1136
fast_read (LISP table)
1140
struct user_type_hooks *p;
1143
f = get_c_file (car (table), (FILE *) NULL);
1150
while ((c = getc (f)))
1156
return (fast_read (table));
1160
FLONM (bashnum) = len;
1161
return (href (car (cdr (table)), bashnum));
1164
tmp = fast_read (table);
1165
hset (car (cdr (table)), flocons (len), tmp);
1170
tmp = fast_read (table);
1171
return (cons (tmp, fast_read (table)));
1175
FLONM (bashnum) = len;
1176
l = make_list (bashnum, NIL);
1180
CAR (tmp) = fast_read (table);
1184
CAR (tmp) = fast_read (table);
1186
CDR (tmp) = fast_read (table);
1189
tmp = newcell (tc_flonum);
1190
fread (&tmp->storage_as.flonum.data,
1191
sizeof (tmp->storage_as.flonum.data),
1197
if (len >= TKBUFFERN)
1198
my_err ("symbol name too long", NIL);
1199
fread (tkbuffer, len, 1, f);
1201
return (rintern (tkbuffer));
1203
p = get_user_type_hooks (c);
1205
return (*p->fast_read) (c, table);
1207
return (my_err ("unknown fast-read opcode", flocons (c)));
1212
array_fast_print (LISP ptr, LISP table)
1216
f = get_c_file (car (table), (FILE *) NULL);
1221
putc (ptr->type, f);
1222
len = ptr->storage_as.string.dim;
1224
fwrite (ptr->storage_as.string.data, len, 1, f);
1226
case tc_double_array:
1227
putc (tc_double_array, f);
1228
len = ptr->storage_as.double_array.dim * sizeof (double);
1230
fwrite (ptr->storage_as.double_array.data, len, 1, f);
1233
putc (tc_long_array, f);
1234
len = ptr->storage_as.long_array.dim * sizeof (long);
1236
fwrite (ptr->storage_as.long_array.data, len, 1, f);
1239
putc (tc_lisp_array, f);
1240
len = ptr->storage_as.lisp_array.dim;
1242
for (j = 0; j < len; ++j)
1243
fast_print (ptr->storage_as.lisp_array.data[j], table);
1246
return (errswitch ());
1251
array_fast_read (int code, LISP table)
1256
f = get_c_file (car (table), (FILE *) NULL);
1261
ptr = strcons (len, NULL);
1262
fread (ptr->storage_as.string.data, len, 1, f);
1263
ptr->storage_as.string.data[len] = 0;
1267
iflag = no_interrupt (1);
1268
ptr = newcell (tc_byte_array);
1269
ptr->storage_as.string.dim = len;
1270
ptr->storage_as.string.data =
1271
(char *) must_malloc (len);
1272
fread (ptr->storage_as.string.data, len, 1, f);
1273
no_interrupt (iflag);
1275
case tc_double_array:
1277
iflag = no_interrupt (1);
1278
ptr = newcell (tc_double_array);
1279
ptr->storage_as.double_array.dim = len;
1280
ptr->storage_as.double_array.data =
1281
(double *) must_malloc (len * sizeof (double));
1282
fread (ptr->storage_as.double_array.data, sizeof (double), len, f);
1283
no_interrupt (iflag);
1287
iflag = no_interrupt (1);
1288
ptr = newcell (tc_long_array);
1289
ptr->storage_as.long_array.dim = len;
1290
ptr->storage_as.long_array.data =
1291
(long *) must_malloc (len * sizeof (long));
1292
fread (ptr->storage_as.long_array.data, sizeof (long), len, f);
1293
no_interrupt (iflag);
1297
FLONM (bashnum) = len;
1298
ptr = cons_array (bashnum, NIL);
1299
for (j = 0; j < len; ++j)
1300
ptr->storage_as.lisp_array.data[j] = fast_read (table);
1303
return (errswitch ());
1311
(x) my_err ("not a number", x);
1312
return ((long) FLONM (x));
1316
get_c_double (LISP x)
1319
(x) my_err ("not a number", x);
1324
make_list (LISP x, LISP v)
1339
lfread (LISP size, LISP file)
1341
long flag, n, ret, m;
1345
f = get_c_file (file, stdin);
1346
flag = no_interrupt (1);
1347
switch (TYPE (size))
1352
buffer = s->storage_as.string.data;
1353
n = s->storage_as.string.dim;
1357
n = get_c_long (size);
1358
buffer = (char *) must_malloc (n + 1);
1362
ret = fread (buffer, 1, n, f);
1367
no_interrupt (flag);
1374
s = cons (NIL, NIL);
1375
s->type = tc_string;
1376
s->storage_as.string.data = buffer;
1377
s->storage_as.string.dim = n;
1381
s = strcons (ret, NULL);
1382
memcpy (s->storage_as.string.data, buffer, ret);
1385
no_interrupt (flag);
1388
no_interrupt (flag);
1389
return (flocons ((double) ret));
1393
lfwrite (LISP string, LISP file)
1399
f = get_c_file (file, stdout);
1400
data = get_c_string_dim (CONSP (string) ? car (string) : string, &dim);
1401
len = CONSP (string) ? get_c_long (cadr (string)) : dim;
1405
my_err ("write length too long", string);
1406
flag = no_interrupt (1);
1407
fwrite (data, 1, len, f);
1408
no_interrupt (flag);
1417
f = get_c_file (file, stdout);
1418
flag = no_interrupt (1);
1420
no_interrupt (flag);
1425
string_length (LISP string)
1428
(string, tc_string) err_wta_str (string);
1429
return (flocons (strlen (string->storage_as.string.data)));
1433
string_dim (LISP string)
1436
(string, tc_string) err_wta_str (string);
1437
return (flocons ((double) string->storage_as.string.dim));
1449
return (strlen (obj->storage_as.string.data));
1451
return (obj->storage_as.string.dim);
1452
case tc_double_array:
1453
return (obj->storage_as.double_array.dim);
1455
return (obj->storage_as.long_array.dim);
1457
return (obj->storage_as.lisp_array.dim);
1461
for (l = obj, n = 0; CONSP (l); l = CDR (l), ++n)
1464
(l) my_err ("improper list to length", obj);
1467
my_err ("wta to length", obj);
1475
return (flocons (nlength (obj)));
1479
number2string (LISP x, LISP b, LISP w, LISP p)
1483
long base, width, prec;
1485
(x) my_err ("wta", x);
1487
width = NNULLP (w) ? get_c_long (w) : -1;
1489
my_err ("width too long", w);
1490
prec = NNULLP (p) ? get_c_long (p) : -1;
1492
my_err ("precision too large", p);
1493
if (NULLP (b) || EQ (sym_e, b) || EQ (sym_f, b))
1497
if ((width >= 0) && (prec >= 0))
1499
NULLP (b) ? "%%%ld.%ldg" :
1500
EQ (sym_e, b) ? "%%%ld.%ldd" : "%%%ld.%ldf",
1502
else if (width >= 0)
1504
NULLP (b) ? "%%%ldg" : EQ (sym_e, b) ? "%%%lde" : "%%%ldf",
1508
NULLP (b) ? "%%.%ldg" : EQ (sym_e, b) ? "%%.%lde" : "%%.%ldf",
1511
sprintf (format, NULLP (b) ? "%%g" : EQ (sym_e, b) ? "%%e" : "%%f");
1513
g_ascii_formatd (buffer, sizeof(buffer), format, y);
1515
else if (((base = get_c_long (b)) == 10) || (base == 8) || (base == 16))
1519
(base == 10) ? "%0*ld" : (base == 8) ? "%0*lo" : "%0*lX",
1524
(base == 10) ? "%ld" : (base == 8) ? "%lo" : "%lX",
1528
my_err ("number base not handled", b);
1529
return (strcons (strlen (buffer), buffer));
1533
string2number (LISP x, LISP b)
1536
long base, value = 0;
1537
double result = 0.0;
1538
str = get_c_string (x);
1541
result = g_ascii_strtod (str, NULL);
1542
else if ((base = get_c_long (b)) == 10)
1544
sscanf (str, "%ld", &value);
1545
result = (double) value;
1549
sscanf (str, "%lo", &value);
1550
result = (double) value;
1552
else if (base == 16)
1554
sscanf (str, "%lx", &value);
1555
result = (double) value;
1557
else if ((base >= 1) && (base <= 16))
1559
for (result = 0.0; *str; ++str)
1560
if (g_ascii_isdigit (*str))
1561
result = result * base + *str - '0';
1562
else if (g_ascii_isxdigit (*str))
1563
result = result * base + g_ascii_toupper (*str) - 'A' + 10;
1566
my_err ("number base not handled", b);
1567
return (flocons (result));
1571
lstrcmp (LISP s1, LISP s2)
1573
return (flocons (strcmp (get_c_string (s1), get_c_string (s2))));
1577
chk_string (LISP s, char **data, long *dim)
1582
*data = s->storage_as.string.data;
1583
*dim = s->storage_as.string.dim;
1590
lstrcpy (LISP dest, LISP src)
1594
chk_string (dest, &d, &ddim);
1595
s = get_c_string (src);
1598
my_err ("string too long", src);
1599
memcpy (d, s, slen);
1605
lstrcat (LISP dest, LISP src)
1607
long ddim, dlen, slen;
1609
chk_string (dest, &d, &ddim);
1610
s = get_c_string (src);
1613
if ((slen + dlen) > ddim)
1614
my_err ("string too long", src);
1615
memcpy (&d[dlen], s, slen);
1621
lstrbreakup (LISP str, LISP lmarker)
1623
char *start, *end, *marker;
1626
start = end = get_c_string (str);
1627
marker = get_c_string (lmarker);
1628
k = strlen (marker);
1633
if (!(end = strstr (start, marker)))
1634
end = &start[strlen (start)];
1635
result = cons (strcons (end - start, start), result);
1636
start = (*end) ? end + k : end;
1638
return (nreverse (result));
1641
return (strcons (strlen (start), start));
1645
lstrunbreakup (LISP elems, LISP lmarker)
1648
for (l = elems, result = NIL; NNULLP (l); l = cdr (l))
1651
result = cons (car (l), result);
1653
result = cons (car (l), cons (lmarker, result));
1654
return (string_append (nreverse (result)));
1660
return (TYPEP (x, tc_string) ? sym_t : NIL);
1663
static char *base64_encode_table = "\
1664
ABCDEFGHIJKLMNOPQRSTUVWXYZ\
1665
abcdefghijklmnopqrstuvwxyz\
1668
static char *base64_decode_table = NULL;
1671
init_base64_table (void)
1674
base64_decode_table = (char *) malloc (256);
1675
memset (base64_decode_table, -1, 256);
1676
for (j = 0; j < 65; ++j)
1677
base64_decode_table[(unsigned char) base64_encode_table[j]] = j;
1680
#define BITMSK(N) ((1 << (N)) - 1)
1682
#define ITEM1(X) (X >> 2) & BITMSK(6)
1683
#define ITEM2(X,Y) ((X & BITMSK(2)) << 4) | ((Y >> 4) & BITMSK(4))
1684
#define ITEM3(X,Y) ((X & BITMSK(4)) << 2) | ((Y >> 6) & BITMSK(2))
1685
#define ITEM4(X) X & BITMSK(6)
1688
base64encode (LISP in)
1690
char *s, *t = base64_encode_table;
1691
unsigned char *p1, *p2;
1693
long j, m, n, chunks, leftover;
1694
s = get_c_string_dim (in, &n);
1697
m = (chunks + ((leftover) ? 1 : 0)) * 4;
1698
out = strcons (m, NULL);
1699
p2 = (unsigned char *) get_c_string (out);
1700
for (j = 0, p1 = (unsigned char *) s; j < chunks; ++j, p1 += 3)
1702
*p2++ = t[ITEM1 (p1[0])];
1703
*p2++ = t[ITEM2 (p1[0], p1[1])];
1704
*p2++ = t[ITEM3 (p1[1], p1[2])];
1705
*p2++ = t[ITEM4 (p1[2])];
1712
*p2++ = t[ITEM1 (p1[0])];
1713
*p2++ = t[ITEM2 (p1[0], 0)];
1714
*p2++ = base64_encode_table[64];
1715
*p2++ = base64_encode_table[64];
1718
*p2++ = t[ITEM1 (p1[0])];
1719
*p2++ = t[ITEM2 (p1[0], p1[1])];
1720
*p2++ = t[ITEM3 (p1[1], 0)];
1721
*p2++ = base64_encode_table[64];
1730
base64decode (LISP in)
1732
char *s, *t = base64_decode_table;
1734
unsigned char *p1, *p2;
1735
long j, m, n, chunks, leftover, item1, item2, item3, item4;
1736
s = get_c_string (in);
1739
return (strcons (0, NULL));
1741
my_err ("illegal base64 data length", in);
1742
if (s[n - 1] == base64_encode_table[64])
1744
if (s[n - 2] == base64_encode_table[64])
1751
chunks = (n / 4) - ((leftover) ? 1 : 0);
1752
m = (chunks * 3) + leftover;
1753
out = strcons (m, NULL);
1754
p2 = (unsigned char *) get_c_string (out);
1755
for (j = 0, p1 = (unsigned char *) s; j < chunks; ++j, p1 += 4)
1757
if ((item1 = t[p1[0]]) & ~BITMSK (6))
1759
if ((item2 = t[p1[1]]) & ~BITMSK (6))
1761
if ((item3 = t[p1[2]]) & ~BITMSK (6))
1763
if ((item4 = t[p1[3]]) & ~BITMSK (6))
1765
*p2++ = (item1 << 2) | (item2 >> 4);
1766
*p2++ = (item2 << 4) | (item3 >> 2);
1767
*p2++ = (item3 << 6) | item4;
1774
if ((item1 = t[p1[0]]) & ~BITMSK (6))
1776
if ((item2 = t[p1[1]]) & ~BITMSK (6))
1778
*p2++ = (item1 << 2) | (item2 >> 4);
1781
if ((item1 = t[p1[0]]) & ~BITMSK (6))
1783
if ((item2 = t[p1[1]]) & ~BITMSK (6))
1785
if ((item3 = t[p1[2]]) & ~BITMSK (6))
1787
*p2++ = (item1 << 2) | (item2 >> 4);
1788
*p2++ = (item2 << 4) | (item3 >> 2);
1797
memq (LISP x, LISP il)
1800
for (l = il; CONSP (l); l = CDR (l))
1804
(x, tmp) return (l);
1808
(l, NIL) return (NIL);
1809
return (my_err ("improper list to memq", il));
1813
member (LISP x, LISP il)
1816
for (l = il; CONSP (l); l = CDR (l))
1820
(equal (x, tmp)) return (l);
1824
(l, NIL) return (NIL);
1825
return (my_err ("improper list to member", il));
1829
memv (LISP x, LISP il)
1832
for (l = il; CONSP (l); l = CDR (l))
1836
(eql (x, tmp)) return (l);
1840
(l, NIL) return (NIL);
1841
return (my_err ("improper list to memv", il));
1846
nth (LISP x, LISP li)
1849
long j, n = get_c_long (x);
1850
for (j = 0, l = li; (j < n) && CONSP (l); ++j)
1856
return (my_err ("bad arg to nth", x));
1859
/* these lxxx_default functions are convenient for manipulating
1860
command-line argument lists */
1863
lref_default (LISP li, LISP x, LISP fcn)
1866
long j, n = get_c_long (x);
1867
for (j = 0, l = li; (j < n) && CONSP (l); ++j)
1874
return (lapply (fcn, NIL));
1880
larg_default (LISP li, LISP x, LISP dval)
1883
long j = 0, n = get_c_long (x);
1888
if (TYPEP (elem, tc_string) && strchr ("-:", *get_c_string (elem)))
1902
lkey_default (LISP li, LISP key, LISP dval)
1907
ckey = get_c_string (key);
1913
if (TYPEP (elem, tc_string) && (*(celem = get_c_string (elem)) == ':') &&
1914
(strncmp (&celem[1], ckey, n) == 0) && (celem[n + 1] == '='))
1915
return (strcons (strlen (&celem[n + 2]), &celem[n + 2]));
1929
writes1 (FILE * f, LISP l)
1934
for (v = l; CONSP (v); v = CDR (v))
1935
writes1 (f, CAR (v));
1943
fput_st (f, get_c_string (v));
1955
return (writes1 (get_c_file (car (args), stdout), cdr (args)));
1963
v2 = CONSP (v1) ? CDR (v1) : my_err ("bad arg to last", l);
1979
(l) my_err ("list is empty", l);
1985
return (cons (CAR (l), butlast (CDR (l))));
1987
return (my_err ("not a list", l));
1991
nconc (LISP a, LISP b)
1996
setcdr (last (a), b);
2001
funcall1 (LISP fcn, LISP a1)
2009
return (SUBR1 (fcn) (a1));
2012
(fcn->storage_as.closure.code, tc_subr_2)
2016
return (SUBR2 (fcn->storage_as.closure.code)
2017
(fcn->storage_as.closure.env, a1));
2020
return (lapply (fcn, cons (a1, NIL)));
2025
funcall2 (LISP fcn, LISP a1, LISP a2)
2034
return (SUBR2 (fcn) (a1, a2));
2036
return (lapply (fcn, cons (a1, cons (a2, NIL))));
2041
lqsort (LISP l, LISP f, LISP g)
2042
/* this is a stupid recursive qsort */
2045
LISP v, mark, less, notless;
2046
for (v = l, n = 0; CONSP (v); v = CDR (v), ++n)
2049
(v) my_err ("bad list to qsort", l);
2053
for (v = l, n = 0; n < j; ++n)
2056
for (less = NIL, notless = NIL, v = l, n = 0; NNULLP (v); v = CDR (v), ++n)
2061
NULLP (g) ? CAR (v) : funcall1 (g, CAR (v)),
2062
NULLP (g) ? mark : funcall1 (g, mark)))
2063
less = cons (CAR (v), less);
2065
notless = cons (CAR (v), notless);
2067
return (nconc (lqsort (less, f, g),
2069
lqsort (notless, f, g))));
2073
string_lessp (LISP s1, LISP s2)
2075
if (strcmp (get_c_string (s1), get_c_string (s2)) < 0)
2082
benchmark_funcall1 (LISP ln, LISP f, LISP a1)
2086
n = get_c_long (ln);
2087
for (j = 0; j < n; ++j)
2088
value = funcall1 (f, a1);
2093
benchmark_funcall2 (LISP l)
2097
LISP f = car (cdr (l));
2098
LISP a1 = car (cdr (cdr (l)));
2099
LISP a2 = car (cdr (cdr (cdr (l))));
2101
n = get_c_long (ln);
2102
for (j = 0; j < n; ++j)
2103
value = funcall2 (f, a1, a2);
2108
benchmark_eval (LISP ln, LISP exp, LISP env)
2112
n = get_c_long (ln);
2113
for (j = 0; j < n; ++j)
2114
value = leval (exp, env);
2119
mapcar1 (LISP fcn, LISP in)
2124
res = ptr = cons (funcall1 (fcn, car (in)), NIL);
2125
for (l = cdr (in); CONSP (l); l = CDR (l))
2126
ptr = CDR (ptr) = cons (funcall1 (fcn, CAR (l)), CDR (ptr));
2131
mapcar2 (LISP fcn, LISP in1, LISP in2)
2133
LISP res, ptr, l1, l2;
2134
if (NULLP (in1) || NULLP (in2))
2136
res = ptr = cons (funcall2 (fcn, car (in1), car (in2)), NIL);
2137
for (l1 = cdr (in1), l2 = cdr (in2); CONSP (l1) && CONSP (l2); l1 = CDR (l1), l2 = CDR (l2))
2138
ptr = CDR (ptr) = cons (funcall2 (fcn, CAR (l1), CAR (l2)), CDR (ptr));
2146
switch (get_c_long (llength (l)))
2149
return (mapcar1 (fcn, car (cdr (l))));
2151
return (mapcar2 (fcn, car (cdr (l)), car (cdr (cdr (l)))));
2153
return (my_err ("mapcar case not handled", l));
2158
lfmod (LISP x, LISP y)
2161
(x) my_err ("wta(1st) to fmod", x);
2163
(y) my_err ("wta(2nd) to fmod", y);
2164
return (flocons (fmod (FLONM (x), FLONM (y))));
2168
lsubset (LISP fcn, LISP l)
2170
LISP result = NIL, v;
2171
for (v = l; CONSP (v); v = CDR (v))
2173
(funcall1 (fcn, CAR (v)))
2174
result = cons (CAR (v), result);
2175
return (nreverse (result));
2179
ass (LISP x, LISP alist, LISP fcn)
2182
for (l = alist; CONSP (l); l = CDR (l))
2185
if (CONSP (tmp) && NNULLP (funcall2 (fcn, CAR (tmp), x)))
2190
(l, NIL) return (NIL);
2191
return (my_err ("improper list to ass", alist));
2195
append2 (LISP l1, LISP l2)
2198
LISP result = NIL, p1, p2;
2199
n = nlength (l1) + nlength (l2);
2202
result = cons (NIL, result);
2205
for (p1 = result, p2 = l1; NNULLP (p2); p1 = cdr (p1), p2 = cdr (p2))
2206
setcar (p1, car (p2));
2207
for (p2 = l2; NNULLP (p2); p1 = cdr (p1), p2 = cdr (p2))
2208
setcar (p1, car (p2));
2225
return (append2 (car (l), cadr (l)));
2227
return (append2 (car (l), append (cdr (l))));
2236
for (j = 0, result = NIL; j < n; ++j)
2237
result = cons (NIL, result);
2239
for (j = 0, ptr = result; j < n; ptr = cdr (ptr), ++j)
2240
setcar (ptr, va_arg (args, LISP));
2247
fast_load (LISP lfname, LISP noeval)
2251
LISP result = NIL, form;
2252
fname = get_c_string (lfname);
2253
if (siod_verbose_level >= 3)
2255
put_st ("fast loading ");
2260
fopen_c (fname, "rb"),
2261
cons_array (flocons (100), NIL),
2263
while (NEQ (stream, form = fast_read (stream)))
2265
if (siod_verbose_level >= 5)
2271
result = cons (form, result);
2273
fclose_l (car (stream));
2274
if (siod_verbose_level >= 3)
2276
return (nreverse (result));
2280
shexstr (char *outstr, void *buff, size_t len)
2282
unsigned char *data = buff;
2284
for (j = 0; j < len; ++j)
2285
sprintf (&outstr[j * 2], "%02X", data[j]);
2289
fast_save (LISP fname, LISP forms, LISP nohash, LISP comment)
2291
char *cname, msgbuff[100], databuff[50];
2296
cname = get_c_string (fname);
2297
if (siod_verbose_level >= 3)
2299
put_st ("fast saving forms to ");
2304
fopen_c (cname, "wb"),
2305
NNULLP (nohash) ? NIL : cons_array (flocons (100), NIL),
2307
f = get_c_file (car (stream), NULL);
2310
fput_st (f, get_c_string (comment));
2311
sprintf (msgbuff, "# Siod Binary Object Save File\n");
2312
fput_st (f, msgbuff);
2313
sprintf (msgbuff, "# sizeof(long) = %d\n# sizeof(double) = %d\n",
2314
(int) sizeof (long), (int) sizeof (double));
2315
fput_st (f, msgbuff);
2316
shexstr (databuff, &l_one, sizeof (l_one));
2317
sprintf (msgbuff, "# 1 = %s\n", databuff);
2318
fput_st (f, msgbuff);
2319
shexstr (databuff, &d_one, sizeof (d_one));
2320
sprintf (msgbuff, "# 1.0 = %s\n", databuff);
2321
fput_st (f, msgbuff);
2322
for (l = forms; NNULLP (l); l = cdr (l))
2323
fast_print (car (l), stream);
2324
fclose_l (car (stream));
2325
if (siod_verbose_level >= 3)
2331
swrite1 (LISP stream, LISP data)
2333
FILE *f = get_c_file (stream, stdout);
2339
fput_st (f, get_c_string (data));
2348
swrite (LISP stream, LISP table, LISP data)
2352
switch (TYPE (data))
2355
value = href (table, data);
2359
swrite1 (stream, CAR (value));
2362
hset (table, data, CDR (value));
2365
swrite1 (stream, value);
2368
n = data->storage_as.lisp_array.dim;
2370
my_err ("no object repeat count", data);
2371
key = data->storage_as.lisp_array.data[0];
2373
(value = href (table, key))
2380
hset (table, key, CDR (value));
2381
value = CAR (value);
2383
m = get_c_long (value);
2384
for (k = 0; k < m; ++k)
2385
for (j = 1; j < n; ++j)
2386
swrite (stream, table, data->storage_as.lisp_array.data[j]);
2389
/* this should be handled similar to the array case */
2391
swrite1 (stream, data);
2399
double cx = get_c_double (x);
2400
return (flocons (cx < 0.0 ? ceil (cx) : floor (cx)));
2404
lpow (LISP x, LISP y)
2407
(x) my_err ("wta(1st) to pow", x);
2409
(y) my_err ("wta(2nd) to pow", y);
2410
return (flocons (pow (FLONM (x), FLONM (y))));
2416
return (flocons (exp (get_c_double (x))));
2422
return (flocons (log (get_c_double (x))));
2428
return (flocons (sin (get_c_double (x))));
2434
return (flocons (cos (get_c_double (x))));
2440
return (flocons (tan (get_c_double (x))));
2446
return (flocons (asin (get_c_double (x))));
2452
return (flocons (acos (get_c_double (x))));
2458
return (flocons (atan (get_c_double (x))));
2462
latan2 (LISP x, LISP y)
2464
return (flocons (atan2 (get_c_double (x), get_c_double (y))));
2474
in = (unsigned char *) get_c_string_dim (a, &dim);
2475
result = strcons (dim * 2, NULL);
2476
for (out = get_c_string (result), j = 0; j < dim; ++j, out += 2)
2477
sprintf (out, "%02x", in[j]);
2484
if (g_ascii_isdigit (c))
2486
if (g_ascii_isxdigit (c))
2487
return (g_ascii_toupper (c) - 'A' + 10);
2492
hexstr2bytes (LISP a)
2498
in = get_c_string (a);
2499
dim = strlen (in) / 2;
2500
result = arcons (tc_byte_array, dim, 0);
2501
out = (unsigned char *) result->storage_as.string.data;
2502
for (j = 0; j < dim; ++j)
2503
out[j] = xdigitvalue (in[j * 2]) * 16 + xdigitvalue (in[j * 2 + 1]);
2508
getprop (LISP plist, LISP key)
2511
for (l = cdr (plist); NNULLP (l); l = cddr (l))
2521
setprop (LISP plist, LISP key, LISP value)
2523
my_err ("not implemented", NIL);
2528
putprop (LISP plist, LISP value, LISP key)
2530
return (setprop (plist, key, value));
2541
return (cintern ("tc_nil"));
2543
return (cintern ("tc_cons"));
2545
return (cintern ("tc_flonum"));
2547
return (cintern ("tc_symbol"));
2549
return (cintern ("tc_subr_0"));
2551
return (cintern ("tc_subr_1"));
2553
return (cintern ("tc_subr_2"));
2555
return (cintern ("tc_subr_2n"));
2557
return (cintern ("tc_subr_3"));
2559
return (cintern ("tc_subr_4"));
2561
return (cintern ("tc_subr_5"));
2563
return (cintern ("tc_lsubr"));
2565
return (cintern ("tc_fsubr"));
2567
return (cintern ("tc_msubr"));
2569
return (cintern ("tc_closure"));
2571
return (cintern ("tc_free_cell"));
2573
return (cintern ("tc_string"));
2575
return (cintern ("tc_byte_array"));
2576
case tc_double_array:
2577
return (cintern ("tc_double_array"));
2579
return (cintern ("tc_long_array"));
2581
return (cintern ("tc_lisp_array"));
2583
return (cintern ("tc_c_file"));
2585
return (flocons (x));
2592
return (car (car (car (x))));
2598
return (car (car (cdr (x))));
2604
return (car (cdr (car (x))));
2610
return (car (cdr (cdr (x))));
2616
return (cdr (car (car (x))));
2622
return (cdr (car (cdr (x))));
2628
return (cdr (cdr (car (x))));
2634
return (cdr (cdr (cdr (x))));
2638
ash (LISP value, LISP n)
2641
m = get_c_long (value);
2647
return (flocons (m));
2651
bitand (LISP a, LISP b)
2653
return (flocons (get_c_long (a) & get_c_long (b)));
2657
bitor (LISP a, LISP b)
2659
return (flocons (get_c_long (a) | get_c_long (b)));
2663
bitxor (LISP a, LISP b)
2665
return (flocons (get_c_long (a) ^ get_c_long (b)));
2671
return (flocons (~get_c_long (a)));
2675
leval_prog1 (LISP args, LISP env)
2678
retval = leval (car (args), env);
2679
for (l = cdr (args); NNULLP (l); l = cdr (l))
2680
leval (car (l), env);
2685
leval_cond (LISP * pform, LISP * penv)
2687
LISP args, env, clause, value, next;
2688
args = cdr (*pform);
2700
clause = car (args);
2701
value = leval (car (clause), env);
2705
clause = cdr (clause);
2714
next = cdr (clause);
2715
while (NNULLP (next))
2717
leval (car (clause), env);
2721
*pform = car (clause);
2728
clause = car (args);
2729
next = cdr (clause);
2733
*pform = car (clause);
2736
value = leval (car (clause), env);
2745
while (NNULLP (next))
2747
leval (car (clause), env);
2751
*pform = car (clause);
2756
lstrspn (LISP str1, LISP str2)
2758
return (flocons (strspn (get_c_string (str1), get_c_string (str2))));
2762
lstrcspn (LISP str1, LISP str2)
2764
return (flocons (strcspn (get_c_string (str1), get_c_string (str2))));
2768
substring_equal (LISP str1, LISP str2, LISP start, LISP end)
2770
char *cstr1, *cstr2;
2772
cstr1 = get_c_string_dim (str1, &len1);
2773
cstr2 = get_c_string_dim (str2, &n);
2774
s = NULLP (start) ? 0 : get_c_long (start);
2775
e = NULLP (end) ? n : get_c_long (end);
2776
if ((s < 0) || (s > e) || (e < 0) || (e > n) || ((e - s) != len1))
2778
return ((memcmp (cstr1, &cstr2[s], e - s) == 0) ? a_true_value () : NIL);
2782
set_eval_history (LISP len, LISP circ)
2785
data = NULLP (len) ? len : make_list (len, NIL);
2788
data = nconc (data, data);
2789
setvar (cintern ("*eval-history-ptr*"), data, NIL);
2790
setvar (cintern ("*eval-history*"), data, NIL);
2795
parser_fasl (LISP ignore)
2797
return (closure (listn (3,
2799
cons_array (flocons (100), NIL),
2801
leval (cintern ("parser_fasl_hook"), NIL)));
2805
parser_fasl_hook (LISP env, LISP f)
2809
result = fast_read (env);
2812
return (get_eof_val ());
2820
init_subr_2 ("aref", aref1);
2821
init_subr_3 ("aset", aset1);
2822
init_lsubr ("string-append", string_append);
2823
init_lsubr ("bytes-append", bytes_append);
2824
init_subr_1 ("string-length", string_length);
2825
init_subr_1 ("string-dimension", string_dim);
2826
init_subr_1 ("read-from-string", read_from_string);
2827
init_subr_3 ("print-to-string", print_to_string);
2828
init_subr_2 ("cons-array", cons_array);
2829
init_subr_2 ("sxhash", sxhash);
2830
init_subr_2 ("equal?", equal);
2831
init_subr_2 ("href", href);
2832
init_subr_3 ("hset", hset);
2833
init_subr_2 ("assoc", assoc);
2834
init_subr_2 ("assv", assv);
2835
init_subr_1 ("fast-read", fast_read);
2836
init_subr_2 ("fast-print", fast_print);
2837
init_subr_2 ("make-list", make_list);
2838
init_subr_2 ("fread", lfread);
2839
init_subr_2 ("fwrite", lfwrite);
2840
init_subr_1 ("fflush", lfflush);
2841
init_subr_1 ("length", llength);
2842
init_subr_4 ("number->string", number2string);
2843
init_subr_2 ("string->number", string2number);
2844
init_subr_3 ("substring", substring);
2845
init_subr_2 ("string-search", string_search);
2846
init_subr_1 ("string-trim", string_trim);
2847
init_subr_1 ("string-trim-left", string_trim_left);
2848
init_subr_1 ("string-trim-right", string_trim_right);
2849
init_subr_1 ("string-upcase", string_upcase);
2850
init_subr_1 ("string-downcase", string_downcase);
2851
init_subr_2 ("strcmp", lstrcmp);
2852
init_subr_2 ("strcat", lstrcat);
2853
init_subr_2 ("strcpy", lstrcpy);
2854
init_subr_2 ("strbreakup", lstrbreakup);
2855
init_subr_2 ("unbreakupstr", lstrunbreakup);
2856
init_subr_1 ("string?", stringp);
2857
gc_protect_sym (&sym_e, "e");
2858
gc_protect_sym (&sym_f, "f");
2859
gc_protect_sym (&sym_plists, "*plists*");
2860
setvar (sym_plists, arcons (tc_lisp_array, 100, 1), NIL);
2861
init_subr_3 ("lref-default", lref_default);
2862
init_subr_3 ("larg-default", larg_default);
2863
init_subr_3 ("lkey-default", lkey_default);
2864
init_lsubr ("list", llist);
2865
init_lsubr ("writes", writes);
2866
init_subr_3 ("qsort", lqsort);
2867
init_subr_2 ("string-lessp", string_lessp);
2868
init_lsubr ("mapcar", mapcar);
2869
init_subr_3 ("mapcar2", mapcar2);
2870
init_subr_2 ("mapcar1", mapcar1);
2871
init_subr_3 ("benchmark-funcall1", benchmark_funcall1);
2872
init_lsubr ("benchmark-funcall2", benchmark_funcall2);
2873
init_subr_3 ("benchmark-eval", benchmark_eval);
2874
init_subr_2 ("fmod", lfmod);
2875
init_subr_2 ("subset", lsubset);
2876
init_subr_1 ("base64encode", base64encode);
2877
init_subr_1 ("base64decode", base64decode);
2878
init_subr_3 ("ass", ass);
2879
init_subr_2 ("append2", append2);
2880
init_lsubr ("append", append);
2881
init_subr_4 ("fast-save", fast_save);
2882
init_subr_2 ("fast-load", fast_load);
2883
init_subr_3 ("swrite", swrite);
2884
init_subr_1 ("trunc", ltrunc);
2885
init_subr_2 ("pow", lpow);
2886
init_subr_1 ("exp", lexp);
2887
init_subr_1 ("log", llog);
2888
init_subr_1 ("sin", lsin);
2889
init_subr_1 ("cos", lcos);
2890
init_subr_1 ("tan", ltan);
2891
init_subr_1 ("asin", lasin);
2892
init_subr_1 ("acos", lacos);
2893
init_subr_1 ("atan", latan);
2894
init_subr_2 ("atan2", latan2);
2895
init_subr_1 ("typeof", ltypeof);
2896
init_subr_1 ("caaar", caaar);
2897
init_subr_1 ("caadr", caadr);
2898
init_subr_1 ("cadar", cadar);
2899
init_subr_1 ("caddr", caddr);
2900
init_subr_1 ("cdaar", cdaar);
2901
init_subr_1 ("cdadr", cdadr);
2902
init_subr_1 ("cddar", cddar);
2903
init_subr_1 ("cdddr", cdddr);
2904
setvar (cintern ("*pi*"), flocons (atan (1.0) * 4), NIL);
2905
init_base64_table ();
2906
init_subr_1 ("array->hexstr", hexstr);
2907
init_subr_1 ("hexstr->bytes", hexstr2bytes);
2908
init_subr_3 ("ass", ass);
2909
init_subr_2 ("bit-and", bitand);
2910
init_subr_2 ("bit-or", bitor);
2911
init_subr_2 ("bit-xor", bitxor);
2912
init_subr_1 ("bit-not", bitnot);
2913
init_msubr ("cond", leval_cond);
2914
init_fsubr ("prog1", leval_prog1);
2915
init_subr_2 ("strspn", lstrspn);
2916
init_subr_2 ("strcspn", lstrcspn);
2917
init_subr_4 ("substring-equal?", substring_equal);
2918
init_subr_1 ("butlast", butlast);
2919
init_subr_2 ("ash", ash);
2920
init_subr_2 ("get", getprop);
2921
init_subr_3 ("setprop", setprop);
2922
init_subr_3 ("putprop", putprop);
2923
init_subr_1 ("last", last);
2924
init_subr_2 ("memq", memq);
2925
init_subr_2 ("memv", memv);
2926
init_subr_2 ("member", member);
2927
init_subr_2 ("nth", nth);
2928
init_subr_2 ("nconc", nconc);
2929
init_subr_2 ("set-eval-history", set_eval_history);
2930
init_subr_1 ("parser_fasl", parser_fasl);
2931
setvar (cintern ("*parser_fasl.scm-loaded*"), a_true_value (), NIL);
2932
init_subr_2 ("parser_fasl_hook", parser_fasl_hook);
2933
init_sliba_version ();
added
removed
plug-ins/script-fu/siod/sliba.c
