home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 2002 April / pcpro0402.iso / essentials / graphics / Gimp / gimp-src-20001226.exe / src / gimp / plug-ins / script-fu / interp_sliba.c < prev    next >
Encoding:
C/C++ Source or Header  |  1999-09-03  |  63.8 KB  |  2,913 lines
  1.  
  2.  
  3. /*
  4.  *                   COPYRIGHT (c) 1988-1994 BY                             *
  5.  *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  6.  *        See the source file SLIB.C for more information.                  *
  7.  
  8.  Array-hacking code moved to another source file.
  9.  
  10.  */
  11.  
  12. #include <stdio.h>
  13. #include <string.h>
  14. #include <setjmp.h>
  15. #include <stdlib.h>
  16. #include <stdarg.h>
  17. #include <ctype.h>
  18. #include <math.h>
  19.  
  20. #include "siod.h"
  21. #include "siodp.h"
  22.  
  23. static void
  24. init_sliba_version (void)
  25. {
  26.   setvar (cintern ("*sliba-version*"),
  27.       cintern ("$Id: interp_sliba.c,v 1.6 1999/09/03 21:16:53 tml Exp $"),
  28.       NIL);
  29. }
  30.  
  31. static LISP sym_plists = NIL;
  32. static LISP bashnum = NIL;
  33. static LISP sym_e = NIL;
  34. static LISP sym_f = NIL;
  35.  
  36. void
  37. init_storage_a1 (long type)
  38. {
  39.   long j;
  40.   struct user_type_hooks *p;
  41.   set_gc_hooks (type,
  42.         array_gc_relocate,
  43.         array_gc_mark,
  44.         array_gc_scan,
  45.         array_gc_free,
  46.         &j);
  47.   set_print_hooks (type, array_prin1);
  48.   p = get_user_type_hooks (type);
  49.   p->fast_print = array_fast_print;
  50.   p->fast_read = array_fast_read;
  51.   p->equal = array_equal;
  52.   p->c_sxhash = array_sxhash;
  53. }
  54.  
  55. void
  56. init_storage_a (void)
  57. {
  58.   gc_protect (&bashnum);
  59.   bashnum = newcell (tc_flonum);
  60.   init_storage_a1 (tc_string);
  61.   init_storage_a1 (tc_double_array);
  62.   init_storage_a1 (tc_long_array);
  63.   init_storage_a1 (tc_lisp_array);
  64.   init_storage_a1 (tc_byte_array);
  65. }
  66.  
  67. LISP
  68. array_gc_relocate (LISP ptr)
  69. {
  70.   LISP nw;
  71.   if ((nw = heap) >= heap_end)
  72.     gc_fatal_error ();
  73.   heap = nw + 1;
  74.   memcpy (nw, ptr, sizeof (struct obj));
  75.   return (nw);
  76. }
  77.  
  78. void
  79. array_gc_scan (LISP ptr)
  80. {
  81.   long j;
  82.   if TYPEP
  83.     (ptr, tc_lisp_array)
  84.       for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
  85.       ptr->storage_as.lisp_array.data[j] =
  86.     gc_relocate (ptr->storage_as.lisp_array.data[j]);
  87. }
  88.  
  89. LISP
  90. array_gc_mark (LISP ptr)
  91. {
  92.   long j;
  93.   if TYPEP
  94.     (ptr, tc_lisp_array)
  95.       for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
  96.       gc_mark (ptr->storage_as.lisp_array.data[j]);
  97.   return (NIL);
  98. }
  99.  
  100. void
  101. array_gc_free (LISP ptr)
  102. {
  103.   switch (ptr->type)
  104.     {
  105.     case tc_string:
  106.     case tc_byte_array:
  107.       free (ptr->storage_as.string.data);
  108.       break;
  109.     case tc_double_array:
  110.       free (ptr->storage_as.double_array.data);
  111.       break;
  112.     case tc_long_array:
  113.       free (ptr->storage_as.long_array.data);
  114.       break;
  115.     case tc_lisp_array:
  116.       free (ptr->storage_as.lisp_array.data);
  117.       break;
  118.     }
  119. }
  120.  
  121. void
  122. array_prin1 (LISP ptr, struct gen_printio *f)
  123. {
  124.   int j;
  125.   switch (ptr->type)
  126.     {
  127.     case tc_string:
  128.       gput_st (f, "\"");
  129.       if (strcspn (ptr->storage_as.string.data, "\"\\\n\r\t") ==
  130.       strlen (ptr->storage_as.string.data))
  131.     gput_st (f, ptr->storage_as.string.data);
  132.       else
  133.     {
  134.       int n, c;
  135.       char cbuff[3];
  136.       n = strlen (ptr->storage_as.string.data);
  137.       for (j = 0; j < n; ++j)
  138.         switch (c = ptr->storage_as.string.data[j])
  139.           {
  140.           case '\\':
  141.           case '"':
  142.         cbuff[0] = '\\';
  143.         cbuff[1] = c;
  144.         cbuff[2] = 0;
  145.         gput_st (f, cbuff);
  146.         break;
  147.           case '\n':
  148.         gput_st (f, "\\n");
  149.         break;
  150.           case '\r':
  151.         gput_st (f, "\\r");
  152.         break;
  153.           case '\t':
  154.         gput_st (f, "\\t");
  155.         break;
  156.           default:
  157.         cbuff[0] = c;
  158.         cbuff[1] = 0;
  159.         gput_st (f, cbuff);
  160.         break;
  161.           }
  162.     }
  163.       gput_st (f, "\"");
  164.       break;
  165.     case tc_double_array:
  166.       gput_st (f, "#(");
  167.       for (j = 0; j < ptr->storage_as.double_array.dim; ++j)
  168.     {
  169.       sprintf (tkbuffer, "%g", ptr->storage_as.double_array.data[j]);
  170.       gput_st (f, tkbuffer);
  171.       if ((j + 1) < ptr->storage_as.double_array.dim)
  172.         gput_st (f, " ");
  173.     }
  174.       gput_st (f, ")");
  175.       break;
  176.     case tc_long_array:
  177.       gput_st (f, "#(");
  178.       for (j = 0; j < ptr->storage_as.long_array.dim; ++j)
  179.     {
  180.       sprintf (tkbuffer, "%ld", ptr->storage_as.long_array.data[j]);
  181.       gput_st (f, tkbuffer);
  182.       if ((j + 1) < ptr->storage_as.long_array.dim)
  183.         gput_st (f, " ");
  184.     }
  185.       gput_st (f, ")");
  186.     case tc_byte_array:
  187.       sprintf (tkbuffer, "#%ld\"", ptr->storage_as.string.dim);
  188.       gput_st (f, tkbuffer);
  189.       for (j = 0; j < ptr->storage_as.string.dim; ++j)
  190.     {
  191.       sprintf (tkbuffer, "%02x", ptr->storage_as.string.data[j] & 0xFF);
  192.       gput_st (f, tkbuffer);
  193.     }
  194.       gput_st (f, "\"");
  195.       break;
  196.     case tc_lisp_array:
  197.       gput_st (f, "#(");
  198.       for (j = 0; j < ptr->storage_as.lisp_array.dim; ++j)
  199.     {
  200.       lprin1g (ptr->storage_as.lisp_array.data[j], f);
  201.       if ((j + 1) < ptr->storage_as.lisp_array.dim)
  202.         gput_st (f, " ");
  203.     }
  204.       gput_st (f, ")");
  205.       break;
  206.     }
  207. }
  208.  
  209. LISP
  210. strcons (long length, char *data)
  211. {
  212.   long flag;
  213.   LISP s;
  214.   flag = no_interrupt (1);
  215.   s = cons (NIL, NIL);
  216.   s->type = tc_string;
  217.   if (length == -1)
  218.     length = strlen (data);
  219.   s->storage_as.string.data = must_malloc (length + 1);
  220.   s->storage_as.string.dim = length;
  221.   if (data)
  222.     memcpy (s->storage_as.string.data, data, length);
  223.   s->storage_as.string.data[length] = 0;
  224.   no_interrupt (flag);
  225.   return (s);
  226. }
  227.  
  228. int
  229. rfs_getc (unsigned char **p)
  230. {
  231.   int i;
  232.   i = **p;
  233.   if (!i)
  234.     return (EOF);
  235.   *p = *p + 1;
  236.   return (i);
  237. }
  238.  
  239. void
  240. rfs_ungetc (unsigned char c, unsigned char **p)
  241. {
  242.   *p = *p - 1;
  243. }
  244.  
  245. LISP
  246. read_from_string (LISP x)
  247. {
  248.   char *p;
  249.   struct gen_readio s;
  250.   p = get_c_string (x);
  251.   s.getc_fcn = (int (*)(void *)) rfs_getc;
  252.   s.ungetc_fcn = (void (*)(int, void *)) rfs_ungetc;
  253.   s.cb_argument = (char *) &p;
  254.   return (readtl (&s));
  255. }
  256.  
  257. int
  258. pts_puts (char *from, void *cb)
  259. {
  260.   LISP into;
  261.   size_t fromlen, intolen, intosize, fitsize;
  262.   into = (LISP) cb;
  263.   fromlen = strlen (from);
  264.   intolen = strlen (into->storage_as.string.data);
  265.   intosize = into->storage_as.string.dim - intolen;
  266.   fitsize = (fromlen < intosize) ? fromlen : intosize;
  267.   memcpy (&into->storage_as.string.data[intolen], from, fitsize);
  268.   into->storage_as.string.data[intolen + fitsize] = 0;
  269.   if (fitsize < fromlen)
  270.     my_err ("print to string overflow", NIL);
  271.   return (1);
  272. }
  273.  
  274. LISP
  275. err_wta_str (LISP exp)
  276. {
  277.   return (my_err ("not a string", exp));
  278. }
  279.  
  280. LISP
  281. print_to_string (LISP exp, LISP str, LISP nostart)
  282. {
  283.   struct gen_printio s;
  284.   if NTYPEP
  285.     (str, tc_string) err_wta_str (str);
  286.   s.putc_fcn = NULL;
  287.   s.puts_fcn = pts_puts;
  288.   s.cb_argument = str;
  289.   if NULLP
  290.     (nostart)
  291.       str->storage_as.string.data[0] = 0;
  292.   lprin1g (exp, &s);
  293.   return (str);
  294. }
  295.  
  296. LISP
  297. aref1 (LISP a, LISP i)
  298. {
  299.   long k;
  300.   if NFLONUMP
  301.     (i) my_err ("bad index to aref", i);
  302.   k = (long) FLONM (i);
  303.   if (k < 0)
  304.     my_err ("negative index to aref", i);
  305.   switch TYPE
  306.     (a)
  307.     {
  308.     case tc_string:
  309.     case tc_byte_array:
  310.       if (k >= a->storage_as.string.dim)
  311.     my_err ("index too large", i);
  312.       return (flocons ((double) a->storage_as.string.data[k]));
  313.     case tc_double_array:
  314.       if (k >= a->storage_as.double_array.dim)
  315.     my_err ("index too large", i);
  316.       return (flocons (a->storage_as.double_array.data[k]));
  317.     case tc_long_array:
  318.       if (k >= a->storage_as.long_array.dim)
  319.     my_err ("index too large", i);
  320.       return (flocons (a->storage_as.long_array.data[k]));
  321.     case tc_lisp_array:
  322.       if (k >= a->storage_as.lisp_array.dim)
  323.     my_err ("index too large", i);
  324.       return (a->storage_as.lisp_array.data[k]);
  325.     default:
  326.       return (my_err ("invalid argument to aref", a));
  327.     }
  328. }
  329.  
  330. void
  331. err1_aset1 (LISP i)
  332. {
  333.   my_err ("index to aset too large", i);
  334. }
  335.  
  336. void
  337. err2_aset1 (LISP v)
  338. {
  339.   my_err ("bad value to store in array", v);
  340. }
  341.  
  342. LISP
  343. aset1 (LISP a, LISP i, LISP v)
  344. {
  345.   long k;
  346.   if NFLONUMP
  347.     (i) my_err ("bad index to aset", i);
  348.   k = (long) FLONM (i);
  349.   if (k < 0)
  350.     my_err ("negative index to aset", i);
  351.   switch TYPE
  352.     (a)
  353.     {
  354.     case tc_string:
  355.     case tc_byte_array:
  356.       if NFLONUMP
  357.     (v) err2_aset1 (v);
  358.       if (k >= a->storage_as.string.dim)
  359.     err1_aset1 (i);
  360.       a->storage_as.string.data[k] = (char) FLONM (v);
  361.       return (v);
  362.     case tc_double_array:
  363.       if NFLONUMP
  364.     (v) err2_aset1 (v);
  365.       if (k >= a->storage_as.double_array.dim)
  366.     err1_aset1 (i);
  367.       a->storage_as.double_array.data[k] = FLONM (v);
  368.       return (v);
  369.     case tc_long_array:
  370.       if NFLONUMP
  371.     (v) err2_aset1 (v);
  372.       if (k >= a->storage_as.long_array.dim)
  373.     err1_aset1 (i);
  374.       a->storage_as.long_array.data[k] = (long) FLONM (v);
  375.       return (v);
  376.     case tc_lisp_array:
  377.       if (k >= a->storage_as.lisp_array.dim)
  378.     err1_aset1 (i);
  379.       a->storage_as.lisp_array.data[k] = v;
  380.       return (v);
  381.     default:
  382.       return (my_err ("invalid argument to aset", a));
  383.     }
  384. }
  385.  
  386. LISP
  387. arcons (long typecode, long n, long initp)
  388. {
  389.   LISP a;
  390.   long flag, j;
  391.   flag = no_interrupt (1);
  392.   a = cons (NIL, NIL);
  393.   switch (typecode)
  394.     {
  395.     case tc_double_array:
  396.       a->storage_as.double_array.dim = n;
  397.       a->storage_as.double_array.data = (double *) must_malloc (n *
  398.                                sizeof (double));
  399.       if (initp)
  400.     for (j = 0; j < n; ++j)
  401.       a->storage_as.double_array.data[j] = 0.0;
  402.       break;
  403.     case tc_long_array:
  404.       a->storage_as.long_array.dim = n;
  405.       a->storage_as.long_array.data = (long *) must_malloc (n * sizeof (long));
  406.       if (initp)
  407.     for (j = 0; j < n; ++j)
  408.       a->storage_as.long_array.data[j] = 0;
  409.       break;
  410.     case tc_string:
  411.       a->storage_as.string.dim = n;
  412.       a->storage_as.string.data = (char *) must_malloc (n + 1);
  413.       a->storage_as.string.data[n] = 0;
  414.       if (initp)
  415.     for (j = 0; j < n; ++j)
  416.       a->storage_as.string.data[j] = ' ';
  417.     case tc_byte_array:
  418.       a->storage_as.string.dim = n;
  419.       a->storage_as.string.data = (char *) must_malloc (n);
  420.       if (initp)
  421.     for (j = 0; j < n; ++j)
  422.       a->storage_as.string.data[j] = 0;
  423.       break;
  424.     case tc_lisp_array:
  425.       a->storage_as.lisp_array.dim = n;
  426.       a->storage_as.lisp_array.data = (LISP *) must_malloc (n * sizeof (LISP));
  427.       for (j = 0; j < n; ++j)
  428.     a->storage_as.lisp_array.data[j] = NIL;
  429.       break;
  430.     default:
  431.       errswitch ();
  432.     }
  433.   a->type = typecode;
  434.   no_interrupt (flag);
  435.   return (a);
  436. }
  437.  
  438. LISP
  439. mallocl (void *place, long size)
  440. {
  441.   long n, r;
  442.   LISP retval;
  443.   n = size / sizeof (long);
  444.   r = size % sizeof (long);
  445.   if (r)
  446.     ++n;
  447.   retval = arcons (tc_long_array, n, 0);
  448.   *(long **) place = retval->storage_as.long_array.data;
  449.   return (retval);
  450. }
  451.  
  452. LISP
  453. cons_array (LISP dim, LISP kind)
  454. {
  455.   LISP a;
  456.   long flag, n, j;
  457.   if (NFLONUMP (dim) || (FLONM (dim) < 0))
  458.     return (my_err ("bad dimension to cons-array", dim));
  459.   else
  460.     n = (long) FLONM (dim);
  461.   flag = no_interrupt (1);
  462.   a = cons (NIL, NIL);
  463.   if EQ
  464.     (cintern ("double"), kind)
  465.     {
  466.       a->type = tc_double_array;
  467.       a->storage_as.double_array.dim = n;
  468.       a->storage_as.double_array.data = (double *) must_malloc (n *
  469.                                sizeof (double));
  470.       for (j = 0; j < n; ++j)
  471.     a->storage_as.double_array.data[j] = 0.0;
  472.     }
  473.   else if EQ
  474.     (cintern ("long"), kind)
  475.     {
  476.       a->type = tc_long_array;
  477.       a->storage_as.long_array.dim = n;
  478.       a->storage_as.long_array.data = (long *) must_malloc (n * sizeof (long));
  479.       for (j = 0; j < n; ++j)
  480.     a->storage_as.long_array.data[j] = 0;
  481.     }
  482.   else if EQ
  483.     (cintern ("string"), kind)
  484.     {
  485.       a->type = tc_string;
  486.       a->storage_as.string.dim = n;
  487.       a->storage_as.string.data = (char *) must_malloc (n + 1);
  488.       a->storage_as.string.data[n] = 0;
  489.       for (j = 0; j < n; ++j)
  490.     a->storage_as.string.data[j] = ' ';
  491.     }
  492.   else if EQ
  493.     (cintern ("byte"), kind)
  494.     {
  495.       a->type = tc_byte_array;
  496.       a->storage_as.string.dim = n;
  497.       a->storage_as.string.data = (char *) must_malloc (n);
  498.       for (j = 0; j < n; ++j)
  499.     a->storage_as.string.data[j] = 0;
  500.     }
  501.   else if (EQ (cintern ("lisp"), kind) || NULLP (kind))
  502.     {
  503.       a->type = tc_lisp_array;
  504.       a->storage_as.lisp_array.dim = n;
  505.       a->storage_as.lisp_array.data = (LISP *) must_malloc (n * sizeof (LISP));
  506.       for (j = 0; j < n; ++j)
  507.     a->storage_as.lisp_array.data[j] = NIL;
  508.     }
  509.   else
  510.     my_err ("bad type of array", kind);
  511.   no_interrupt (flag);
  512.   return (a);
  513. }
  514.  
  515. LISP
  516. string_append (LISP args)
  517. {
  518.   long size;
  519.   LISP l, s;
  520.   char *data;
  521.   size = 0;
  522.   for (l = args; NNULLP (l); l = cdr (l))
  523.     size += strlen (get_c_string (car (l)));
  524.   s = strcons (size, NULL);
  525.   data = s->storage_as.string.data;
  526.   data[0] = 0;
  527.   for (l = args; NNULLP (l); l = cdr (l))
  528.     strcat (data, get_c_string (car (l)));
  529.   return (s);
  530. }
  531.  
  532. LISP
  533. bytes_append (LISP args)
  534. {
  535.   long size, n, j;
  536.   LISP l, s;
  537.   char *data, *ptr;
  538.   size = 0;
  539.   for (l = args; NNULLP (l); l = cdr (l))
  540.     {
  541.       get_c_string_dim (car (l), &n);
  542.       size += n;
  543.     }
  544.   s = arcons (tc_byte_array, size, 0);
  545.   data = s->storage_as.string.data;
  546.   for (j = 0, l = args; NNULLP (l); l = cdr (l))
  547.     {
  548.       ptr = get_c_string_dim (car (l), &n);
  549.       memcpy (&data[j], ptr, n);
  550.       j += n;
  551.     }
  552.   return (s);
  553. }
  554.  
  555. LISP
  556. substring (LISP str, LISP start, LISP end)
  557. {
  558.   long s, e, n;
  559.   char *data;
  560.   data = get_c_string_dim (str, &n);
  561.   s = get_c_long (start);
  562.   if NULLP
  563.     (end)
  564.       e = n;
  565.   else
  566.     e = get_c_long (end);
  567.   if ((s < 0) || (s > e))
  568.     my_err ("bad start index", start);
  569.   if ((e < 0) || (e > n))
  570.     my_err ("bad end index", end);
  571.   return (strcons (e - s, &data[s]));
  572. }
  573.  
  574. LISP
  575. string_search (LISP token, LISP str)
  576. {
  577.   char *s1, *s2, *ptr;
  578.   s1 = get_c_string (str);
  579.   s2 = get_c_string (token);
  580.   ptr = strstr (s1, s2);
  581.   if (ptr)
  582.     return (flocons (ptr - s1));
  583.   else
  584.     return (NIL);
  585. }
  586.  
  587. #define IS_TRIM_SPACE(_x) (strchr(" \t\r\n",(_x)))
  588.  
  589. LISP
  590. string_trim (LISP str)
  591. {
  592.   char *start, *end; /*, *sp = " \t\r\n";*/
  593.   start = get_c_string (str);
  594.   while (*start && IS_TRIM_SPACE (*start))
  595.     ++start;
  596.   end = &start[strlen (start)];
  597.   while ((end > start) && IS_TRIM_SPACE (*(end - 1)))
  598.     --end;
  599.   return (strcons (end - start, start));
  600. }
  601.  
  602. LISP
  603. string_trim_left (LISP str)
  604. {
  605.   char *start, *end;
  606.   start = get_c_string (str);
  607.   while (*start && IS_TRIM_SPACE (*start))
  608.     ++start;
  609.   end = &start[strlen (start)];
  610.   return (strcons (end - start, start));
  611. }
  612.  
  613. LISP
  614. string_trim_right (LISP str)
  615. {
  616.   char *start, *end;
  617.   start = get_c_string (str);
  618.   end = &start[strlen (start)];
  619.   while ((end > start) && IS_TRIM_SPACE (*(end - 1)))
  620.     --end;
  621.   return (strcons (end - start, start));
  622. }
  623.  
  624. LISP
  625. string_upcase (LISP str)
  626. {
  627.   LISP result;
  628.   char *s1, *s2;
  629.   long j, n;
  630.   s1 = get_c_string (str);
  631.   n = strlen (s1);
  632.   result = strcons (n, s1);
  633.   s2 = get_c_string (result);
  634.   for (j = 0; j < n; ++j)
  635.     s2[j] = toupper (s2[j]);
  636.   return (result);
  637. }
  638.  
  639. LISP
  640. string_downcase (LISP str)
  641. {
  642.   LISP result;
  643.   char *s1, *s2;
  644.   long j, n;
  645.   s1 = get_c_string (str);
  646.   n = strlen (s1);
  647.   result = strcons (n, s1);
  648.   s2 = get_c_string (result);
  649.   for (j = 0; j < n; ++j)
  650.     s2[j] = tolower (s2[j]);
  651.   return (result);
  652. }
  653.  
  654. LISP
  655. lreadstring (struct gen_readio * f)
  656. {
  657.   int j, c, n, ndigits;
  658.   char *p;
  659.   j = 0;
  660.   p = tkbuffer;
  661.   while (((c = GETC_FCN (f)) != '"') && (c != EOF))
  662.     {
  663.       if (c == '\\')
  664.     {
  665.       c = GETC_FCN (f);
  666.       if (c == EOF)
  667.         my_err ("eof after \\", NIL);
  668.       switch (c)
  669.         {
  670.         case '\\':
  671.           c = '\\';
  672.           break;
  673.         case 'n':
  674.           c = '\n';
  675.           break;
  676.         case 't':
  677.           c = '\t';
  678.           break;
  679.         case 'r':
  680.           c = '\r';
  681.           break;
  682.         case 'd':
  683.           c = 0x04;
  684.           break;
  685.         case 'N':
  686.           c = 0;
  687.           break;
  688.         case 's':
  689.           c = ' ';
  690.           break;
  691.         case '0':
  692.         case '1':
  693.         case '2':
  694.         case '3':
  695.         case '4':
  696.         case '5':
  697.         case '6':
  698.         case '7':
  699.           n = c - '0';
  700.           ndigits = 1;
  701.           while (ndigits < 3)
  702.         {
  703.           c = GETC_FCN (f);
  704.           if (c == EOF)
  705.             my_err ("eof after \\0", NIL);
  706.           if (c >= '0' && c <= '7')
  707.             {
  708.               n = n * 8 + c - '0';
  709.               ndigits++;
  710.             }
  711.           else
  712.             {
  713.               UNGETC_FCN (c, f);
  714.               break;
  715.             }
  716.         }
  717.           c = n;
  718.         }
  719.     }
  720.       if ((j + 1) >= TKBUFFERN)
  721.     my_err ("read string overflow", NIL);
  722.       ++j;
  723.       *p++ = c;
  724.     }
  725.   *p = 0;
  726.   return (strcons (j, tkbuffer));
  727. }
  728.  
  729.  
  730. LISP
  731. lreadsharp (struct gen_readio * f)
  732. {
  733.   LISP obj, l, result;
  734.   long j, n;
  735.   int c;
  736.   c = GETC_FCN (f);
  737.   switch (c)
  738.     {
  739.     case '(':
  740.       UNGETC_FCN (c, f);
  741.       obj = lreadr (f);
  742.       n = nlength (obj);
  743.       result = arcons (tc_lisp_array, n, 1);
  744.       for (l = obj, j = 0; j < n; l = cdr (l), ++j)
  745.     result->storage_as.lisp_array.data[j] = car (l);
  746.       return (result);
  747.     case '.':
  748.       obj = lreadr (f);
  749.       return (leval (obj, NIL));
  750.     case 'f':
  751.       return (NIL);
  752.     case 't':
  753.       return (flocons (1));
  754.     default:
  755.       return (my_err ("readsharp syntax not handled", NIL));
  756.     }
  757. }
  758.  
  759. #define HASH_COMBINE(_h1,_h2,_mod) ((((_h1) * 17 + 1) ^ (_h2)) % (_mod))
  760.  
  761. long
  762. c_sxhash (LISP obj, long n)
  763. {
  764.   long hash;
  765.   unsigned char *s;
  766.   LISP tmp;
  767.   struct user_type_hooks *p;
  768.   STACK_CHECK (&obj);
  769.   INTERRUPT_CHECK ();
  770.   switch TYPE
  771.     (obj)
  772.     {
  773.     case tc_nil:
  774.       return (0);
  775.     case tc_cons:
  776.       hash = c_sxhash (CAR (obj), n);
  777.       for (tmp = CDR (obj); CONSP (tmp); tmp = CDR (tmp))
  778.     hash = HASH_COMBINE (hash, c_sxhash (CAR (tmp), n), n);
  779.       hash = HASH_COMBINE (hash, c_sxhash (tmp, n), n);
  780.       return (hash);
  781.     case tc_symbol:
  782.       for (hash = 0, s = (unsigned char *) PNAME (obj); *s; ++s)
  783.     hash = HASH_COMBINE (hash, *s, n);
  784.       return (hash);
  785.     case tc_subr_0:
  786.     case tc_subr_1:
  787.     case tc_subr_2:
  788.     case tc_subr_3:
  789.     case tc_subr_4:
  790.     case tc_subr_5:
  791.     case tc_lsubr:
  792.     case tc_fsubr:
  793.     case tc_msubr:
  794.       for (hash = 0, s = (unsigned char *) obj->storage_as.subr.name; *s; ++s)
  795.     hash = HASH_COMBINE (hash, *s, n);
  796.       return (hash);
  797.     case tc_flonum:
  798.       return (((unsigned long) FLONM (obj)) % n);
  799.     default:
  800.       p = get_user_type_hooks (TYPE (obj));
  801.       if (p->c_sxhash)
  802.     return ((*p->c_sxhash) (obj, n));
  803.       else
  804.     return (0);
  805.     }
  806. }
  807.  
  808. LISP
  809. sxhash (LISP obj, LISP n)
  810. {
  811.   return (flocons (c_sxhash (obj, FLONUMP (n) ? (long) FLONM (n) : 10000)));
  812. }
  813.  
  814. LISP
  815. equal (LISP a, LISP b)
  816. {
  817.   struct user_type_hooks *p;
  818.   long atype;
  819.   STACK_CHECK (&a);
  820. loop:
  821.   INTERRUPT_CHECK ();
  822.   if EQ
  823.     (a, b) return (sym_t);
  824.   atype = TYPE (a);
  825.   if (atype != TYPE (b))
  826.     return (NIL);
  827.   switch (atype)
  828.     {
  829.     case tc_cons:
  830.       if NULLP
  831.     (equal (car (a), car (b))) return (NIL);
  832.       a = cdr (a);
  833.       b = cdr (b);
  834.       goto loop;
  835.     case tc_flonum:
  836.       return ((FLONM (a) == FLONM (b)) ? sym_t : NIL);
  837.     case tc_symbol:
  838.       return (NIL);
  839.     default:
  840.       p = get_user_type_hooks (atype);
  841.       if (p->equal)
  842.     return ((*p->equal) (a, b));
  843.       else
  844.     return (NIL);
  845.     }
  846. }
  847.  
  848. LISP
  849. array_equal (LISP a, LISP b)
  850. {
  851.   long j, len;
  852.   switch (TYPE (a))
  853.     {
  854.     case tc_string:
  855.     case tc_byte_array:
  856.       len = a->storage_as.string.dim;
  857.       if (len != b->storage_as.string.dim)
  858.     return (NIL);
  859.       if (memcmp (a->storage_as.string.data, b->storage_as.string.data, len) == 0)
  860.     return (sym_t);
  861.       else
  862.     return (NIL);
  863.     case tc_long_array:
  864.       len = a->storage_as.long_array.dim;
  865.       if (len != b->storage_as.long_array.dim)
  866.     return (NIL);
  867.       if (memcmp (a->storage_as.long_array.data,
  868.           b->storage_as.long_array.data,
  869.           len * sizeof (long)) == 0)
  870.       return (sym_t);
  871.       else
  872.     return (NIL);
  873.     case tc_double_array:
  874.       len = a->storage_as.double_array.dim;
  875.       if (len != b->storage_as.double_array.dim)
  876.     return (NIL);
  877.       for (j = 0; j < len; ++j)
  878.     if (a->storage_as.double_array.data[j] !=
  879.         b->storage_as.double_array.data[j])
  880.       return (NIL);
  881.       return (sym_t);
  882.     case tc_lisp_array:
  883.       len = a->storage_as.lisp_array.dim;
  884.       if (len != b->storage_as.lisp_array.dim)
  885.     return (NIL);
  886.       for (j = 0; j < len; ++j)
  887.     if NULLP
  888.       (equal (a->storage_as.lisp_array.data[j],
  889.           b->storage_as.lisp_array.data[j]))
  890.         return (NIL);
  891.       return (sym_t);
  892.     default:
  893.       return (errswitch ());
  894.     }
  895. }
  896.  
  897. long
  898. array_sxhash (LISP a, long n)
  899. {
  900.   long j, len, hash;
  901.   unsigned char *char_data;
  902.   unsigned long *long_data;
  903.   double *double_data;
  904.   switch (TYPE (a))
  905.     {
  906.     case tc_string:
  907.     case tc_byte_array:
  908.       len = a->storage_as.string.dim;
  909.       for (j = 0, hash = 0, char_data = (unsigned char *) a->storage_as.string.data;
  910.        j < len;
  911.        ++j, ++char_data)
  912.     hash = HASH_COMBINE (hash, *char_data, n);
  913.       return (hash);
  914.     case tc_long_array:
  915.       len = a->storage_as.long_array.dim;
  916.       for (j = 0, hash = 0, long_data = (unsigned long *) a->storage_as.long_array.data;
  917.        j < len;
  918.        ++j, ++long_data)
  919.     hash = HASH_COMBINE (hash, *long_data % n, n);
  920.       return (hash);
  921.     case tc_double_array:
  922.       len = a->storage_as.double_array.dim;
  923.       for (j = 0, hash = 0, double_data = a->storage_as.double_array.data;
  924.        j < len;
  925.        ++j, ++double_data)
  926.     hash = HASH_COMBINE (hash, (unsigned long) *double_data % n, n);
  927.       return (hash);
  928.     case tc_lisp_array:
  929.       len = a->storage_as.lisp_array.dim;
  930.       for (j = 0, hash = 0; j < len; ++j)
  931.     hash = HASH_COMBINE (hash,
  932.                  c_sxhash (a->storage_as.lisp_array.data[j], n),
  933.                  n);
  934.       return (hash);
  935.     default:
  936.       errswitch ();
  937.       return (0);
  938.     }
  939. }
  940.  
  941. long
  942. href_index (LISP table, LISP key)
  943. {
  944.   long index;
  945.   if NTYPEP
  946.     (table, tc_lisp_array) my_err ("not a hash table", table);
  947.   index = c_sxhash (key, table->storage_as.lisp_array.dim);
  948.   if ((index < 0) || (index >= table->storage_as.lisp_array.dim))
  949.     {
  950.       my_err ("sxhash inconsistency", table);
  951.       return (0);
  952.     }
  953.   else
  954.     return (index);
  955. }
  956.  
  957. LISP
  958. href (LISP table, LISP key)
  959. {
  960.   return (cdr (assoc (key,
  961.           table->storage_as.lisp_array.data[href_index (table, key)])));
  962. }
  963.  
  964. LISP
  965. hset (LISP table, LISP key, LISP value)
  966. {
  967.   long index;
  968.   LISP cell, l;
  969.   index = href_index (table, key);
  970.   l = table->storage_as.lisp_array.data[index];
  971.   if NNULLP
  972.     (cell = assoc (key, l))
  973.       return (setcdr (cell, value));
  974.   cell = cons (key, value);
  975.   table->storage_as.lisp_array.data[index] = cons (cell, l);
  976.   return (value);
  977. }
  978.  
  979. LISP
  980. assoc (LISP x, LISP alist)
  981. {
  982.   LISP l, tmp;
  983.   for (l = alist; CONSP (l); l = CDR (l))
  984.     {
  985.       tmp = CAR (l);
  986.       if (CONSP (tmp) && equal (CAR (tmp), x))
  987.     return (tmp);
  988.       INTERRUPT_CHECK ();
  989.     }
  990.   if EQ
  991.     (l, NIL) return (NIL);
  992.   return (my_err ("improper list to assoc", alist));
  993. }
  994.  
  995. LISP
  996. assv (LISP x, LISP alist)
  997. {
  998.   LISP l, tmp;
  999.   for (l = alist; CONSP (l); l = CDR (l))
  1000.     {
  1001.       tmp = CAR (l);
  1002.       if (CONSP (tmp) && NNULLP (eql (CAR (tmp), x)))
  1003.     return (tmp);
  1004.       INTERRUPT_CHECK ();
  1005.     }
  1006.   if EQ
  1007.     (l, NIL) return (NIL);
  1008.   return (my_err ("improper list to assv", alist));
  1009. }
  1010.  
  1011. void
  1012. put_long (long i, FILE * f)
  1013. {
  1014.   fwrite (&i, sizeof (long), 1, f);
  1015. }
  1016.  
  1017. long
  1018. get_long (FILE * f)
  1019. {
  1020.   long i;
  1021.   fread (&i, sizeof (long), 1, f);
  1022.   return (i);
  1023. }
  1024.  
  1025. long
  1026. fast_print_table (LISP obj, LISP table)
  1027. {
  1028.   FILE *f;
  1029.   LISP ht, index;
  1030.   f = get_c_file (car (table), (FILE *) NULL);
  1031.   if NULLP
  1032.     (ht = car (cdr (table)))
  1033.       return (1);
  1034.   index = href (ht, obj);
  1035.   if NNULLP
  1036.     (index)
  1037.     {
  1038.       putc (FO_fetch, f);
  1039.       put_long (get_c_long (index), f);
  1040.       return (0);
  1041.     }
  1042.   if NULLP
  1043.     (index = car (cdr (cdr (table))))
  1044.       return (1);
  1045.   hset (ht, obj, index);
  1046.   FLONM (bashnum) = 1.0;
  1047.   setcar (cdr (cdr (table)), plus (index, bashnum));
  1048.   putc (FO_store, f);
  1049.   put_long (get_c_long (index), f);
  1050.   return (1);
  1051. }
  1052.  
  1053. LISP
  1054. fast_print (LISP obj, LISP table)
  1055. {
  1056.   FILE *f;
  1057.   long len;
  1058.   LISP tmp;
  1059.   struct user_type_hooks *p;
  1060.   STACK_CHECK (&obj);
  1061.   f = get_c_file (car (table), (FILE *) NULL);
  1062.   switch (TYPE (obj))
  1063.     {
  1064.     case tc_nil:
  1065.       putc (tc_nil, f);
  1066.       return (NIL);
  1067.     case tc_cons:
  1068.       for (len = 0, tmp = obj; CONSP (tmp); tmp = CDR (tmp))
  1069.     {
  1070.       INTERRUPT_CHECK ();
  1071.       ++len;
  1072.     }
  1073.       if (len == 1)
  1074.     {
  1075.       putc (tc_cons, f);
  1076.       fast_print (car (obj), table);
  1077.       fast_print (cdr (obj), table);
  1078.     }
  1079.       else if NULLP
  1080.     (tmp)
  1081.     {
  1082.       putc (FO_list, f);
  1083.       put_long (len, f);
  1084.       for (tmp = obj; CONSP (tmp); tmp = CDR (tmp))
  1085.         fast_print (CAR (tmp), table);
  1086.     }
  1087.       else
  1088.     {
  1089.       putc (FO_listd, f);
  1090.       put_long (len, f);
  1091.       for (tmp = obj; CONSP (tmp); tmp = CDR (tmp))
  1092.         fast_print (CAR (tmp), table);
  1093.       fast_print (tmp, table);
  1094.     }
  1095.       return (NIL);
  1096.     case tc_flonum:
  1097.       putc (tc_flonum, f);
  1098.       fwrite (&obj->storage_as.flonum.data,
  1099.           sizeof (obj->storage_as.flonum.data),
  1100.           1,
  1101.           f);
  1102.       return (NIL);
  1103.     case tc_symbol:
  1104.       if (fast_print_table (obj, table))
  1105.     {
  1106.       putc (tc_symbol, f);
  1107.       len = strlen (PNAME (obj));
  1108.       if (len >= TKBUFFERN)
  1109.         my_err ("symbol name too long", obj);
  1110.       put_long (len, f);
  1111.       fwrite (PNAME (obj), len, 1, f);
  1112.       return (sym_t);
  1113.     }
  1114.       else
  1115.     return (NIL);
  1116.     default:
  1117.       p = get_user_type_hooks (TYPE (obj));
  1118.       if (p->fast_print)
  1119.     return ((*p->fast_print) (obj, table));
  1120.       else
  1121.     return (my_err ("cannot fast-print", obj));
  1122.     }
  1123. }
  1124.  
  1125. LISP
  1126. fast_read (LISP table)
  1127. {
  1128.   FILE *f;
  1129.   LISP tmp, l;
  1130.   struct user_type_hooks *p;
  1131.   int c;
  1132.   long len;
  1133.   f = get_c_file (car (table), (FILE *) NULL);
  1134.   c = getc (f);
  1135.   if (c == EOF)
  1136.     return (table);
  1137.   switch (c)
  1138.     {
  1139.     case FO_comment:
  1140.       while ((c = getc (f)))
  1141.     switch (c)
  1142.       {
  1143.       case EOF:
  1144.         return (table);
  1145.       case '\n':
  1146.         return (fast_read (table));
  1147.       }
  1148.     case FO_fetch:
  1149.       len = get_long (f);
  1150.       FLONM (bashnum) = len;
  1151.       return (href (car (cdr (table)), bashnum));
  1152.     case FO_store:
  1153.       len = get_long (f);
  1154.       tmp = fast_read (table);
  1155.       hset (car (cdr (table)), flocons (len), tmp);
  1156.       return (tmp);
  1157.     case tc_nil:
  1158.       return (NIL);
  1159.     case tc_cons:
  1160.       tmp = fast_read (table);
  1161.       return (cons (tmp, fast_read (table)));
  1162.     case FO_list:
  1163.     case FO_listd:
  1164.       len = get_long (f);
  1165.       FLONM (bashnum) = len;
  1166.       l = make_list (bashnum, NIL);
  1167.       tmp = l;
  1168.       while (len > 1)
  1169.     {
  1170.       CAR (tmp) = fast_read (table);
  1171.       tmp = CDR (tmp);
  1172.       --len;
  1173.     }
  1174.       CAR (tmp) = fast_read (table);
  1175.       if (c == FO_listd)
  1176.     CDR (tmp) = fast_read (table);
  1177.       return (l);
  1178.     case tc_flonum:
  1179.       tmp = newcell (tc_flonum);
  1180.       fread (&tmp->storage_as.flonum.data,
  1181.          sizeof (tmp->storage_as.flonum.data),
  1182.          1,
  1183.          f);
  1184.       return (tmp);
  1185.     case tc_symbol:
  1186.       len = get_long (f);
  1187.       if (len >= TKBUFFERN)
  1188.     my_err ("symbol name too long", NIL);
  1189.       fread (tkbuffer, len, 1, f);
  1190.       tkbuffer[len] = 0;
  1191.       return (rintern (tkbuffer));
  1192.     default:
  1193.       p = get_user_type_hooks (c);
  1194.       if (p->fast_read)
  1195.     return (*p->fast_read) (c, table);
  1196.       else
  1197.     return (my_err ("unknown fast-read opcode", flocons (c)));
  1198.     }
  1199. }
  1200.  
  1201. LISP
  1202. array_fast_print (LISP ptr, LISP table)
  1203. {
  1204.   int j, len;
  1205.   FILE *f;
  1206.   f = get_c_file (car (table), (FILE *) NULL);
  1207.   switch (ptr->type)
  1208.     {
  1209.     case tc_string:
  1210.     case tc_byte_array:
  1211.       putc (ptr->type, f);
  1212.       len = ptr->storage_as.string.dim;
  1213.       put_long (len, f);
  1214.       fwrite (ptr->storage_as.string.data, len, 1, f);
  1215.       return (NIL);
  1216.     case tc_double_array:
  1217.       putc (tc_double_array, f);
  1218.       len = ptr->storage_as.double_array.dim * sizeof (double);
  1219.       put_long (len, f);
  1220.       fwrite (ptr->storage_as.double_array.data, len, 1, f);
  1221.       return (NIL);
  1222.     case tc_long_array:
  1223.       putc (tc_long_array, f);
  1224.       len = ptr->storage_as.long_array.dim * sizeof (long);
  1225.       put_long (len, f);
  1226.       fwrite (ptr->storage_as.long_array.data, len, 1, f);
  1227.       return (NIL);
  1228.     case tc_lisp_array:
  1229.       putc (tc_lisp_array, f);
  1230.       len = ptr->storage_as.lisp_array.dim;
  1231.       put_long (len, f);
  1232.       for (j = 0; j < len; ++j)
  1233.     fast_print (ptr->storage_as.lisp_array.data[j], table);
  1234.       return (NIL);
  1235.     default:
  1236.       return (errswitch ());
  1237.     }
  1238. }
  1239.  
  1240. LISP
  1241. array_fast_read (int code, LISP table)
  1242. {
  1243.   long j, len, iflag;
  1244.   FILE *f;
  1245.   LISP ptr;
  1246.   f = get_c_file (car (table), (FILE *) NULL);
  1247.   switch (code)
  1248.     {
  1249.     case tc_string:
  1250.       len = get_long (f);
  1251.       ptr = strcons (len, NULL);
  1252.       fread (ptr->storage_as.string.data, len, 1, f);
  1253.       ptr->storage_as.string.data[len] = 0;
  1254.       return (ptr);
  1255.     case tc_byte_array:
  1256.       len = get_long (f);
  1257.       iflag = no_interrupt (1);
  1258.       ptr = newcell (tc_byte_array);
  1259.       ptr->storage_as.string.dim = len;
  1260.       ptr->storage_as.string.data =
  1261.     (char *) must_malloc (len);
  1262.       fread (ptr->storage_as.string.data, len, 1, f);
  1263.       no_interrupt (iflag);
  1264.       return (ptr);
  1265.     case tc_double_array:
  1266.       len = get_long (f);
  1267.       iflag = no_interrupt (1);
  1268.       ptr = newcell (tc_double_array);
  1269.       ptr->storage_as.double_array.dim = len;
  1270.       ptr->storage_as.double_array.data =
  1271.     (double *) must_malloc (len * sizeof (double));
  1272.       fread (ptr->storage_as.double_array.data, sizeof (double), len, f);
  1273.       no_interrupt (iflag);
  1274.       return (ptr);
  1275.     case tc_long_array:
  1276.       len = get_long (f);
  1277.       iflag = no_interrupt (1);
  1278.       ptr = newcell (tc_long_array);
  1279.       ptr->storage_as.long_array.dim = len;
  1280.       ptr->storage_as.long_array.data =
  1281.     (long *) must_malloc (len * sizeof (long));
  1282.       fread (ptr->storage_as.long_array.data, sizeof (long), len, f);
  1283.       no_interrupt (iflag);
  1284.       return (ptr);
  1285.     case tc_lisp_array:
  1286.       len = get_long (f);
  1287.       FLONM (bashnum) = len;
  1288.       ptr = cons_array (bashnum, NIL);
  1289.       for (j = 0; j < len; ++j)
  1290.     ptr->storage_as.lisp_array.data[j] = fast_read (table);
  1291.       return (ptr);
  1292.     default:
  1293.       return (errswitch ());
  1294.     }
  1295. }
  1296.  
  1297. long
  1298. get_c_long (LISP x)
  1299. {
  1300.   if NFLONUMP
  1301.     (x) my_err ("not a number", x);
  1302.   return ((long) FLONM (x));
  1303. }
  1304.  
  1305. double
  1306. get_c_double (LISP x)
  1307. {
  1308.   if NFLONUMP
  1309.     (x) my_err ("not a number", x);
  1310.   return (FLONM (x));
  1311. }
  1312.  
  1313. LISP
  1314. make_list (LISP x, LISP v)
  1315. {
  1316.   long n;
  1317.   LISP l;
  1318.   n = get_c_long (x);
  1319.   l = NIL;
  1320.   while (n > 0)
  1321.     {
  1322.       l = cons (v, l);
  1323.       --n;
  1324.     }
  1325.   return (l);
  1326. }
  1327.  
  1328. LISP
  1329. lfread (LISP size, LISP file)
  1330. {
  1331.   long flag, n, ret, m;
  1332.   char *buffer;
  1333.   LISP s;
  1334.   FILE *f;
  1335.   f = get_c_file (file, stdin);
  1336.   flag = no_interrupt (1);
  1337.   switch (TYPE (size))
  1338.     {
  1339.     case tc_string:
  1340.     case tc_byte_array:
  1341.       s = size;
  1342.       buffer = s->storage_as.string.data;
  1343.       n = s->storage_as.string.dim;
  1344.       m = 0;
  1345.       break;
  1346.     default:
  1347.       n = get_c_long (size);
  1348.       buffer = (char *) must_malloc (n + 1);
  1349.       buffer[n] = 0;
  1350.       m = 1;
  1351.     }
  1352.   ret = fread (buffer, 1, n, f);
  1353.   if (ret == 0)
  1354.     {
  1355.       if (m)
  1356.     free (buffer);
  1357.       no_interrupt (flag);
  1358.       return (NIL);
  1359.     }
  1360.   if (m)
  1361.     {
  1362.       if (ret == n)
  1363.     {
  1364.       s = cons (NIL, NIL);
  1365.       s->type = tc_string;
  1366.       s->storage_as.string.data = buffer;
  1367.       s->storage_as.string.dim = n;
  1368.     }
  1369.       else
  1370.     {
  1371.       s = strcons (ret, NULL);
  1372.       memcpy (s->storage_as.string.data, buffer, ret);
  1373.       free (buffer);
  1374.     }
  1375.       no_interrupt (flag);
  1376.       return (s);
  1377.     }
  1378.   no_interrupt (flag);
  1379.   return (flocons ((double) ret));
  1380. }
  1381.  
  1382. LISP
  1383. lfwrite (LISP string, LISP file)
  1384. {
  1385.   FILE *f;
  1386.   long flag;
  1387.   char *data;
  1388.   long dim, len;
  1389.   f = get_c_file (file, stdout);
  1390.   data = get_c_string_dim (CONSP (string) ? car (string) : string, &dim);
  1391.   len = CONSP (string) ? get_c_long (cadr (string)) : dim;
  1392.   if (len <= 0)
  1393.     return (NIL);
  1394.   if (len > dim)
  1395.     my_err ("write length too long", string);
  1396.   flag = no_interrupt (1);
  1397.   fwrite (data, 1, len, f);
  1398.   no_interrupt (flag);
  1399.   return (NIL);
  1400. }
  1401.  
  1402. LISP
  1403. lfflush (LISP file)
  1404. {
  1405.   FILE *f;
  1406.   long flag;
  1407.   f = get_c_file (file, stdout);
  1408.   flag = no_interrupt (1);
  1409.   fflush (f);
  1410.   no_interrupt (flag);
  1411.   return (NIL);
  1412. }
  1413.  
  1414. LISP
  1415. string_length (LISP string)
  1416. {
  1417.   if NTYPEP
  1418.     (string, tc_string) err_wta_str (string);
  1419.   return (flocons (strlen (string->storage_as.string.data)));
  1420. }
  1421.  
  1422. LISP
  1423. string_dim (LISP string)
  1424. {
  1425.   if NTYPEP
  1426.     (string, tc_string) err_wta_str (string);
  1427.   return (flocons ((double) string->storage_as.string.dim));
  1428. }
  1429.  
  1430. long
  1431. nlength (LISP obj)
  1432. {
  1433.   LISP l;
  1434.   long n;
  1435.   switch TYPE
  1436.     (obj)
  1437.     {
  1438.     case tc_string:
  1439.       return (strlen (obj->storage_as.string.data));
  1440.     case tc_byte_array:
  1441.       return (obj->storage_as.string.dim);
  1442.     case tc_double_array:
  1443.       return (obj->storage_as.double_array.dim);
  1444.     case tc_long_array:
  1445.       return (obj->storage_as.long_array.dim);
  1446.     case tc_lisp_array:
  1447.       return (obj->storage_as.lisp_array.dim);
  1448.     case tc_nil:
  1449.       return (0);
  1450.     case tc_cons:
  1451.       for (l = obj, n = 0; CONSP (l); l = CDR (l), ++n)
  1452.     INTERRUPT_CHECK ();
  1453.       if NNULLP
  1454.     (l) my_err ("improper list to length", obj);
  1455.       return (n);
  1456.     default:
  1457.       my_err ("wta to length", obj);
  1458.       return (0);
  1459.     }
  1460. }
  1461.  
  1462. LISP
  1463. llength (LISP obj)
  1464. {
  1465.   return (flocons (nlength (obj)));
  1466. }
  1467.  
  1468. LISP
  1469. number2string (LISP x, LISP b, LISP w, LISP p)
  1470. {
  1471.   char buffer[1000];
  1472.   double y;
  1473.   long base, width, prec;
  1474.   if NFLONUMP
  1475.     (x) my_err ("wta", x);
  1476.   y = FLONM (x);
  1477.   width = NNULLP (w) ? get_c_long (w) : -1;
  1478.   if (width > 100)
  1479.     my_err ("width too long", w);
  1480.   prec = NNULLP (p) ? get_c_long (p) : -1;
  1481.   if (prec > 100)
  1482.     my_err ("precision too large", p);
  1483.   if (NULLP (b) || EQ (sym_e, b) || EQ (sym_f, b))
  1484.     {
  1485.       if ((width >= 0) && (prec >= 0))
  1486.     sprintf (buffer,
  1487.          NULLP (b) ? "% *.*g" : EQ (sym_e, b) ? "% *.*e" : "% *.*f",
  1488.          width,
  1489.          prec,
  1490.          y);
  1491.       else if (width >= 0)
  1492.     sprintf (buffer,
  1493.          NULLP (b) ? "% *g" : EQ (sym_e, b) ? "% *e" : "% *f",
  1494.          width,
  1495.          y);
  1496.       else if (prec >= 0)
  1497.     sprintf (buffer,
  1498.          NULLP (b) ? "%.*g" : EQ (sym_e, b) ? "%.*e" : "%.*f",
  1499.          prec,
  1500.          y);
  1501.       else
  1502.     sprintf (buffer,
  1503.          NULLP (b) ? "%g" : EQ (sym_e, b) ? "%e" : "%f",
  1504.          y);
  1505.     }
  1506.   else if (((base = get_c_long (b)) == 10) || (base == 8) || (base == 16))
  1507.     {
  1508.       if (width >= 0)
  1509.     sprintf (buffer,
  1510.          (base == 10) ? "%0*ld" : (base == 8) ? "%0*lo" : "%0*lX",
  1511.          width,
  1512.          (long) y);
  1513.       else
  1514.     sprintf (buffer,
  1515.          (base == 10) ? "%ld" : (base == 8) ? "%lo" : "%lX",
  1516.          (long) y);
  1517.     }
  1518.   else
  1519.     my_err ("number base not handled", b);
  1520.   return (strcons (strlen (buffer), buffer));
  1521. }
  1522.  
  1523. LISP
  1524. string2number (LISP x, LISP b)
  1525. {
  1526.   char *str;
  1527.   long base, value = 0;
  1528.   double result = 0.0;
  1529.   str = get_c_string (x);
  1530.   if NULLP
  1531.     (b)
  1532.       result = atof (str);
  1533.   else if ((base = get_c_long (b)) == 10)
  1534.     {
  1535.       sscanf (str, "%ld", &value);
  1536.       result = (double) value;
  1537.     }
  1538.   else if (base == 8)
  1539.     {
  1540.       sscanf (str, "%lo", &value);
  1541.       result = (double) value;
  1542.     }
  1543.   else if (base == 16)
  1544.     {
  1545.       sscanf (str, "%lx", &value);
  1546.       result = (double) value;
  1547.     }
  1548.   else if ((base >= 1) && (base <= 16))
  1549.     {
  1550.       for (result = 0.0; *str; ++str)
  1551.     if (isdigit (*str))
  1552.       result = result * base + *str - '0';
  1553.     else if (isxdigit (*str))
  1554.       result = result * base + toupper (*str) - 'A' + 10;
  1555.     }
  1556.   else
  1557.     my_err ("number base not handled", b);
  1558.   return (flocons (result));
  1559. }
  1560.  
  1561. LISP
  1562. lstrcmp (LISP s1, LISP s2)
  1563. {
  1564.   return (flocons (strcmp (get_c_string (s1), get_c_string (s2))));
  1565. }
  1566.  
  1567. void
  1568. chk_string (LISP s, char **data, long *dim)
  1569. {
  1570.   if TYPEP
  1571.     (s, tc_string)
  1572.     {
  1573.       *data = s->storage_as.string.data;
  1574.       *dim = s->storage_as.string.dim;
  1575.     }
  1576.   else
  1577.     err_wta_str (s);
  1578. }
  1579.  
  1580. LISP
  1581. lstrcpy (LISP dest, LISP src)
  1582. {
  1583.   long ddim, slen;
  1584.   char *d, *s;
  1585.   chk_string (dest, &d, &ddim);
  1586.   s = get_c_string (src);
  1587.   slen = strlen (s);
  1588.   if (slen > ddim)
  1589.     my_err ("string too long", src);
  1590.   memcpy (d, s, slen);
  1591.   d[slen] = 0;
  1592.   return (NIL);
  1593. }
  1594.  
  1595. LISP
  1596. lstrcat (LISP dest, LISP src)
  1597. {
  1598.   long ddim, dlen, slen;
  1599.   char *d, *s;
  1600.   chk_string (dest, &d, &ddim);
  1601.   s = get_c_string (src);
  1602.   slen = strlen (s);
  1603.   dlen = strlen (d);
  1604.   if ((slen + dlen) > ddim)
  1605.     my_err ("string too long", src);
  1606.   memcpy (&d[dlen], s, slen);
  1607.   d[dlen + slen] = 0;
  1608.   return (NIL);
  1609. }
  1610.  
  1611. LISP
  1612. lstrbreakup (LISP str, LISP lmarker)
  1613. {
  1614.   char *start, *end, *marker;
  1615.   size_t k;
  1616.   LISP result = NIL;
  1617.   start = get_c_string (str);
  1618.   marker = get_c_string (lmarker);
  1619.   k = strlen (marker);
  1620.   while (*start)
  1621.     {
  1622.       if (!(end = strstr (start, marker)))
  1623.     end = &start[strlen (start)];
  1624.       result = cons (strcons (end - start, start), result);
  1625.       start = (*end) ? end + k : end;
  1626.     }
  1627.   return (nreverse (result));
  1628. }
  1629.  
  1630. LISP
  1631. lstrunbreakup (LISP elems, LISP lmarker)
  1632. {
  1633.   LISP result, l;
  1634.   for (l = elems, result = NIL; NNULLP (l); l = cdr (l))
  1635.     if EQ
  1636.       (l, elems)
  1637.     result = cons (car (l), result);
  1638.     else
  1639.       result = cons (car (l), cons (lmarker, result));
  1640.   return (string_append (nreverse (result)));
  1641. }
  1642.  
  1643. LISP
  1644. stringp (LISP x)
  1645. {
  1646.   return (TYPEP (x, tc_string) ? sym_t : NIL);
  1647. }
  1648.  
  1649. static char *base64_encode_table = "\
  1650. ABCDEFGHIJKLMNOPQRSTUVWXYZ\
  1651. abcdefghijklmnopqrstuvwxyz\
  1652. 0123456789+/=";
  1653.  
  1654. static char *base64_decode_table = NULL;
  1655.  
  1656. static void
  1657. init_base64_table (void)
  1658. {
  1659.   int j;
  1660.   base64_decode_table = (char *) malloc (256);
  1661.   memset (base64_decode_table, -1, 256);
  1662.   for (j = 0; j < 65; ++j)
  1663.     base64_decode_table[(unsigned char) base64_encode_table[j]] = j;
  1664. }
  1665.  
  1666. #define BITMSK(N) ((1 << (N)) - 1)
  1667.  
  1668. #define ITEM1(X)   (X >> 2) & BITMSK(6)
  1669. #define ITEM2(X,Y) ((X & BITMSK(2)) << 4) | ((Y >> 4) & BITMSK(4))
  1670. #define ITEM3(X,Y) ((X & BITMSK(4)) << 2) | ((Y >> 6) & BITMSK(2))
  1671. #define ITEM4(X)   X & BITMSK(6)
  1672.  
  1673. LISP
  1674. base64encode (LISP in)
  1675. {
  1676.   char *s, *t = base64_encode_table;
  1677.   unsigned char *p1, *p2;
  1678.   LISP out;
  1679.   long j, m, n, chunks, leftover;
  1680.   s = get_c_string_dim (in, &n);
  1681.   chunks = n / 3;
  1682.   leftover = n % 3;
  1683.   m = (chunks + ((leftover) ? 1 : 0)) * 4;
  1684.   out = strcons (m, NULL);
  1685.   p2 = (unsigned char *) get_c_string (out);
  1686.   for (j = 0, p1 = (unsigned char *) s; j < chunks; ++j, p1 += 3)
  1687.     {
  1688.       *p2++ = t[ITEM1 (p1[0])];
  1689.       *p2++ = t[ITEM2 (p1[0], p1[1])];
  1690.       *p2++ = t[ITEM3 (p1[1], p1[2])];
  1691.       *p2++ = t[ITEM4 (p1[2])];
  1692.     }
  1693.   switch (leftover)
  1694.     {
  1695.     case 0:
  1696.       break;
  1697.     case 1:
  1698.       *p2++ = t[ITEM1 (p1[0])];
  1699.       *p2++ = t[ITEM2 (p1[0], 0)];
  1700.       *p2++ = base64_encode_table[64];
  1701.       *p2++ = base64_encode_table[64];
  1702.       break;
  1703.     case 2:
  1704.       *p2++ = t[ITEM1 (p1[0])];
  1705.       *p2++ = t[ITEM2 (p1[0], p1[1])];
  1706.       *p2++ = t[ITEM3 (p1[1], 0)];
  1707.       *p2++ = base64_encode_table[64];
  1708.       break;
  1709.     default:
  1710.       errswitch ();
  1711.     }
  1712.   return (out);
  1713. }
  1714.  
  1715. LISP
  1716. base64decode (LISP in)
  1717. {
  1718.   char *s, *t = base64_decode_table;
  1719.   LISP out;
  1720.   unsigned char *p1, *p2;
  1721.   long j, m, n, chunks, leftover, item1, item2, item3, item4;
  1722.   s = get_c_string (in);
  1723.   n = strlen (s);
  1724.   if (n == 0)
  1725.     return (strcons (0, NULL));
  1726.   if (n % 4)
  1727.     my_err ("illegal base64 data length", in);
  1728.   if (s[n - 1] == base64_encode_table[64])
  1729.     {
  1730.       if (s[n - 2] == base64_encode_table[64])
  1731.     leftover = 1;
  1732.       else
  1733.     leftover = 2;
  1734.     }
  1735.   else
  1736.     leftover = 0;
  1737.   chunks = (n / 4) - ((leftover) ? 1 : 0);
  1738.   m = (chunks * 3) + leftover;
  1739.   out = strcons (m, NULL);
  1740.   p2 = (unsigned char *) get_c_string (out);
  1741.   for (j = 0, p1 = (unsigned char *) s; j < chunks; ++j, p1 += 4)
  1742.     {
  1743.       if ((item1 = t[p1[0]]) & ~BITMSK (6))
  1744.     return (NIL);
  1745.       if ((item2 = t[p1[1]]) & ~BITMSK (6))
  1746.     return (NIL);
  1747.       if ((item3 = t[p1[2]]) & ~BITMSK (6))
  1748.     return (NIL);
  1749.       if ((item4 = t[p1[3]]) & ~BITMSK (6))
  1750.     return (NIL);
  1751.       *p2++ = (item1 << 2) | (item2 >> 4);
  1752.       *p2++ = (item2 << 4) | (item3 >> 2);
  1753.       *p2++ = (item3 << 6) | item4;
  1754.     }
  1755.   switch (leftover)
  1756.     {
  1757.     case 0:
  1758.       break;
  1759.     case 1:
  1760.       if ((item1 = t[p1[0]]) & ~BITMSK (6))
  1761.     return (NIL);
  1762.       if ((item2 = t[p1[1]]) & ~BITMSK (6))
  1763.     return (NIL);
  1764.       *p2++ = (item1 << 2) | (item2 >> 4);
  1765.       break;
  1766.     case 2:
  1767.       if ((item1 = t[p1[0]]) & ~BITMSK (6))
  1768.     return (NIL);
  1769.       if ((item2 = t[p1[1]]) & ~BITMSK (6))
  1770.     return (NIL);
  1771.       if ((item3 = t[p1[2]]) & ~BITMSK (6))
  1772.     return (NIL);
  1773.       *p2++ = (item1 << 2) | (item2 >> 4);
  1774.       *p2++ = (item2 << 4) | (item3 >> 2);
  1775.       break;
  1776.     default:
  1777.       errswitch ();
  1778.     }
  1779.   return (out);
  1780. }
  1781.  
  1782. LISP
  1783. memq (LISP x, LISP il)
  1784. {
  1785.   LISP l, tmp;
  1786.   for (l = il; CONSP (l); l = CDR (l))
  1787.     {
  1788.       tmp = CAR (l);
  1789.       if EQ
  1790.     (x, tmp) return (l);
  1791.       INTERRUPT_CHECK ();
  1792.     }
  1793.   if EQ
  1794.     (l, NIL) return (NIL);
  1795.   return (my_err ("improper list to memq", il));
  1796. }
  1797.  
  1798. LISP
  1799. member (LISP x, LISP il)
  1800. {
  1801.   LISP l, tmp;
  1802.   for (l = il; CONSP (l); l = CDR (l))
  1803.     {
  1804.       tmp = CAR (l);
  1805.       if NNULLP
  1806.     (equal (x, tmp)) return (l);
  1807.       INTERRUPT_CHECK ();
  1808.     }
  1809.   if EQ
  1810.     (l, NIL) return (NIL);
  1811.   return (my_err ("improper list to member", il));
  1812. }
  1813.  
  1814. LISP
  1815. memv (LISP x, LISP il)
  1816. {
  1817.   LISP l, tmp;
  1818.   for (l = il; CONSP (l); l = CDR (l))
  1819.     {
  1820.       tmp = CAR (l);
  1821.       if NNULLP
  1822.     (eql (x, tmp)) return (l);
  1823.       INTERRUPT_CHECK ();
  1824.     }
  1825.   if EQ
  1826.     (l, NIL) return (NIL);
  1827.   return (my_err ("improper list to memv", il));
  1828. }
  1829.  
  1830.  
  1831. LISP
  1832. nth (LISP x, LISP li)
  1833. {
  1834.   LISP l;
  1835.   long j, n = get_c_long (x);
  1836.   for (j = 0, l = li; (j < n) && CONSP (l); ++j)
  1837.     l = CDR (l);
  1838.   if CONSP
  1839.     (l)
  1840.       return (CAR (l));
  1841.   else
  1842.     return (my_err ("bad arg to nth", x));
  1843. }
  1844.  
  1845. /* these lxxx_default functions are convenient for manipulating
  1846.    command-line argument lists */
  1847.  
  1848. LISP
  1849. lref_default (LISP li, LISP x, LISP fcn)
  1850. {
  1851.   LISP l;
  1852.   long j, n = get_c_long (x);
  1853.   for (j = 0, l = li; (j < n) && CONSP (l); ++j)
  1854.     l = CDR (l);
  1855.   if CONSP
  1856.     (l)
  1857.       return (CAR (l));
  1858.   else if NNULLP
  1859.     (fcn)
  1860.       return (lapply (fcn, NIL));
  1861.   else
  1862.     return (NIL);
  1863. }
  1864.  
  1865. LISP
  1866. larg_default (LISP li, LISP x, LISP dval)
  1867. {
  1868.   LISP l = li, elem;
  1869.   long j = 0, n = get_c_long (x);
  1870.   while NNULLP
  1871.     (l)
  1872.     {
  1873.       elem = car (l);
  1874.       if (TYPEP (elem, tc_string) && strchr ("-:", *get_c_string (elem)))
  1875.     l = cdr (l);
  1876.       else if (j == n)
  1877.     return (elem);
  1878.       else
  1879.     {
  1880.       l = cdr (l);
  1881.       ++j;
  1882.     }
  1883.     }
  1884.   return (dval);
  1885. }
  1886.  
  1887. LISP
  1888. lkey_default (LISP li, LISP key, LISP dval)
  1889. {
  1890.   LISP l = li, elem;
  1891.   char *ckey, *celem;
  1892.   long n;
  1893.   ckey = get_c_string (key);
  1894.   n = strlen (ckey);
  1895.   while NNULLP
  1896.     (l)
  1897.     {
  1898.       elem = car (l);
  1899.       if (TYPEP (elem, tc_string) && (*(celem = get_c_string (elem)) == ':') &&
  1900.       (strncmp (&celem[1], ckey, n) == 0) && (celem[n + 1] == '='))
  1901.     return (strcons (strlen (&celem[n + 2]), &celem[n + 2]));
  1902.       l = cdr (l);
  1903.     }
  1904.   return (dval);
  1905. }
  1906.  
  1907.  
  1908. LISP
  1909. llist (LISP l)
  1910. {
  1911.   return (l);
  1912. }
  1913.  
  1914. LISP
  1915. writes1 (FILE * f, LISP l)
  1916. {
  1917.   LISP v;
  1918.   STACK_CHECK (&v);
  1919.   INTERRUPT_CHECK ();
  1920.   for (v = l; CONSP (v); v = CDR (v))
  1921.     writes1 (f, CAR (v));
  1922.   switch TYPE
  1923.     (v)
  1924.     {
  1925.     case tc_nil:
  1926.       break;
  1927.     case tc_symbol:
  1928.     case tc_string:
  1929.       fput_st (f, get_c_string (v));
  1930.       break;
  1931.     default:
  1932.       lprin1f (v, f);
  1933.       break;
  1934.     }
  1935.   return (NIL);
  1936. }
  1937.  
  1938. LISP
  1939. writes (LISP args)
  1940. {
  1941.   return (writes1 (get_c_file (car (args), stdout), cdr (args)));
  1942. }
  1943.  
  1944. LISP
  1945. last (LISP l)
  1946. {
  1947.   LISP v1, v2;
  1948.   v1 = l;
  1949.   v2 = CONSP (v1) ? CDR (v1) : my_err ("bad arg to last", l);
  1950.   while (CONSP (v2))
  1951.     {
  1952.       INTERRUPT_CHECK ();
  1953.       v1 = v2;
  1954.       v2 = CDR (v2);
  1955.     }
  1956.   return (v1);
  1957. }
  1958.  
  1959. LISP
  1960. butlast (LISP l)
  1961. {
  1962.   INTERRUPT_CHECK ();
  1963.   STACK_CHECK (&l);
  1964.   if NULLP
  1965.     (l) my_err ("list is empty", l);
  1966.   if CONSP (l)
  1967.     {
  1968.       if NULLP (CDR (l))
  1969.     return (NIL);
  1970.       else
  1971.     return (cons (CAR (l), butlast (CDR (l))));
  1972.     }
  1973.   return (my_err ("not a list", l));
  1974. }
  1975.  
  1976. LISP
  1977. nconc (LISP a, LISP b)
  1978. {
  1979.   if NULLP
  1980.     (a)
  1981.       return (b);
  1982.   setcdr (last (a), b);
  1983.   return (a);
  1984. }
  1985.  
  1986. LISP
  1987. funcall1 (LISP fcn, LISP a1)
  1988. {
  1989.   switch TYPE
  1990.     (fcn)
  1991.     {
  1992.     case tc_subr_1:
  1993.       STACK_CHECK (&fcn);
  1994.       INTERRUPT_CHECK ();
  1995.       return (SUBR1 (fcn) (a1));
  1996.     case tc_closure:
  1997.       if TYPEP
  1998.     (fcn->storage_as.closure.code, tc_subr_2)
  1999.     {
  2000.       STACK_CHECK (&fcn);
  2001.       INTERRUPT_CHECK ();
  2002.       return (SUBR2 (fcn->storage_as.closure.code)
  2003.           (fcn->storage_as.closure.env, a1));
  2004.     }
  2005.     default:
  2006.       return (lapply (fcn, cons (a1, NIL)));
  2007.     }
  2008. }
  2009.  
  2010. LISP
  2011. funcall2 (LISP fcn, LISP a1, LISP a2)
  2012. {
  2013.   switch TYPE
  2014.     (fcn)
  2015.     {
  2016.     case tc_subr_2:
  2017.     case tc_subr_2n:
  2018.       STACK_CHECK (&fcn);
  2019.       INTERRUPT_CHECK ();
  2020.       return (SUBR2 (fcn) (a1, a2));
  2021.     default:
  2022.       return (lapply (fcn, cons (a1, cons (a2, NIL))));
  2023.     }
  2024. }
  2025.  
  2026. LISP
  2027. lqsort (LISP l, LISP f, LISP g)
  2028.      /* this is a stupid recursive qsort */
  2029. {
  2030.   int j, n;
  2031.   LISP v, mark, less, notless;
  2032.   for (v = l, n = 0; CONSP (v); v = CDR (v), ++n)
  2033.     INTERRUPT_CHECK ();
  2034.   if NNULLP
  2035.     (v) my_err ("bad list to qsort", l);
  2036.   if (n == 0)
  2037.     return (NIL);
  2038.   j = rand () % n;
  2039.   for (v = l, n = 0; n < j; ++n)
  2040.     v = CDR (v);
  2041.   mark = CAR (v);
  2042.   for (less = NIL, notless = NIL, v = l, n = 0; NNULLP (v); v = CDR (v), ++n)
  2043.     if (j != n)
  2044.       {
  2045.     if NNULLP
  2046.       (funcall2 (f,
  2047.              NULLP (g) ? CAR (v) : funcall1 (g, CAR (v)),
  2048.              NULLP (g) ? mark : funcall1 (g, mark)))
  2049.         less = cons (CAR (v), less);
  2050.     else
  2051.       notless = cons (CAR (v), notless);
  2052.       }
  2053.   return (nconc (lqsort (less, f, g),
  2054.          cons (mark,
  2055.                lqsort (notless, f, g))));
  2056. }
  2057.  
  2058. LISP
  2059. string_lessp (LISP s1, LISP s2)
  2060. {
  2061.   if (strcmp (get_c_string (s1), get_c_string (s2)) < 0)
  2062.     return (sym_t);
  2063.   else
  2064.     return (NIL);
  2065. }
  2066.  
  2067. LISP
  2068. benchmark_funcall1 (LISP ln, LISP f, LISP a1)
  2069. {
  2070.   long j, n;
  2071.   LISP value = NIL;
  2072.   n = get_c_long (ln);
  2073.   for (j = 0; j < n; ++j)
  2074.     value = funcall1 (f, a1);
  2075.   return (value);
  2076. }
  2077.  
  2078. LISP
  2079. benchmark_funcall2 (LISP l)
  2080. {
  2081.   long j, n;
  2082.   LISP ln = car (l);
  2083.   LISP f = car (cdr (l));
  2084.   LISP a1 = car (cdr (cdr (l)));
  2085.   LISP a2 = car (cdr (cdr (cdr (l))));
  2086.   LISP value = NULL;
  2087.   n = get_c_long (ln);
  2088.   for (j = 0; j < n; ++j)
  2089.     value = funcall2 (f, a1, a2);
  2090.   return (value);
  2091. }
  2092.  
  2093. LISP
  2094. benchmark_eval (LISP ln, LISP exp, LISP env)
  2095. {
  2096.   long j, n;
  2097.   LISP value = NIL;
  2098.   n = get_c_long (ln);
  2099.   for (j = 0; j < n; ++j)
  2100.     value = leval (exp, env);
  2101.   return (value);
  2102. }
  2103.  
  2104. LISP
  2105. mapcar1 (LISP fcn, LISP in)
  2106. {
  2107.   LISP res, ptr, l;
  2108.   if NULLP
  2109.     (in) return (NIL);
  2110.   res = ptr = cons (funcall1 (fcn, car (in)), NIL);
  2111.   for (l = cdr (in); CONSP (l); l = CDR (l))
  2112.     ptr = CDR (ptr) = cons (funcall1 (fcn, CAR (l)), CDR (ptr));
  2113.   return (res);
  2114. }
  2115.  
  2116. LISP
  2117. mapcar2 (LISP fcn, LISP in1, LISP in2)
  2118. {
  2119.   LISP res, ptr, l1, l2;
  2120.   if (NULLP (in1) || NULLP (in2))
  2121.     return (NIL);
  2122.   res = ptr = cons (funcall2 (fcn, car (in1), car (in2)), NIL);
  2123.   for (l1 = cdr (in1), l2 = cdr (in2); CONSP (l1) && CONSP (l2); l1 = CDR (l1), l2 = CDR (l2))
  2124.     ptr = CDR (ptr) = cons (funcall2 (fcn, CAR (l1), CAR (l2)), CDR (ptr));
  2125.   return (res);
  2126. }
  2127.  
  2128. LISP
  2129. mapcar (LISP l)
  2130. {
  2131.   LISP fcn = car (l);
  2132.   switch (get_c_long (llength (l)))
  2133.     {
  2134.     case 2:
  2135.       return (mapcar1 (fcn, car (cdr (l))));
  2136.     case 3:
  2137.       return (mapcar2 (fcn, car (cdr (l)), car (cdr (cdr (l)))));
  2138.     default:
  2139.       return (my_err ("mapcar case not handled", l));
  2140.     }
  2141. }
  2142.  
  2143. LISP
  2144. lfmod (LISP x, LISP y)
  2145. {
  2146.   if NFLONUMP
  2147.     (x) my_err ("wta(1st) to fmod", x);
  2148.   if NFLONUMP
  2149.     (y) my_err ("wta(2nd) to fmod", y);
  2150.   return (flocons (fmod (FLONM (x), FLONM (y))));
  2151. }
  2152.  
  2153. LISP
  2154. lsubset (LISP fcn, LISP l)
  2155. {
  2156.   LISP result = NIL, v;
  2157.   for (v = l; CONSP (v); v = CDR (v))
  2158.     if NNULLP
  2159.       (funcall1 (fcn, CAR (v)))
  2160.     result = cons (CAR (v), result);
  2161.   return (nreverse (result));
  2162. }
  2163.  
  2164. LISP
  2165. ass (LISP x, LISP alist, LISP fcn)
  2166. {
  2167.   LISP l, tmp;
  2168.   for (l = alist; CONSP (l); l = CDR (l))
  2169.     {
  2170.       tmp = CAR (l);
  2171.       if (CONSP (tmp) && NNULLP (funcall2 (fcn, CAR (tmp), x)))
  2172.     return (tmp);
  2173.       INTERRUPT_CHECK ();
  2174.     }
  2175.   if EQ
  2176.     (l, NIL) return (NIL);
  2177.   return (my_err ("improper list to ass", alist));
  2178. }
  2179.  
  2180. LISP
  2181. append2 (LISP l1, LISP l2)
  2182. {
  2183.   long n;
  2184.   LISP result = NIL, p1, p2;
  2185.   n = nlength (l1) + nlength (l2);
  2186.   while (n > 0)
  2187.     {
  2188.       result = cons (NIL, result);
  2189.       --n;
  2190.     }
  2191.   for (p1 = result, p2 = l1; NNULLP (p2); p1 = cdr (p1), p2 = cdr (p2))
  2192.     setcar (p1, car (p2));
  2193.   for (p2 = l2; NNULLP (p2); p1 = cdr (p1), p2 = cdr (p2))
  2194.     setcar (p1, car (p2));
  2195.   return (result);
  2196. }
  2197.  
  2198. LISP
  2199. append (LISP l)
  2200. {
  2201.   STACK_CHECK (&l);
  2202.   INTERRUPT_CHECK ();
  2203.   if NULLP
  2204.     (l)
  2205.       return (NIL);
  2206.   else if NULLP
  2207.     (cdr (l))
  2208.       return (car (l));
  2209.   else if NULLP
  2210.     (cddr (l))
  2211.       return (append2 (car (l), cadr (l)));
  2212.   else
  2213.     return (append2 (car (l), append (cdr (l))));
  2214. }
  2215.  
  2216. LISP
  2217. listn (long n,...)
  2218. {
  2219.   LISP result, ptr;
  2220.   long j;
  2221.   va_list args;
  2222.   for (j = 0, result = NIL; j < n; ++j)
  2223.     result = cons (NIL, result);
  2224.   va_start (args, n);
  2225.   for (j = 0, ptr = result; j < n; ptr = cdr (ptr), ++j)
  2226.     setcar (ptr, va_arg (args, LISP));
  2227.   va_end (args);
  2228.   return (result);
  2229. }
  2230.  
  2231.  
  2232. LISP
  2233. fast_load (LISP lfname, LISP noeval)
  2234. {
  2235.   char *fname;
  2236.   LISP stream;
  2237.   LISP result = NIL, form;
  2238.   fname = get_c_string (lfname);
  2239.   if (siod_verbose_level >= 3)
  2240.     {
  2241.       put_st ("fast loading ");
  2242.       put_st (fname);
  2243.       put_st ("\n");
  2244.     }
  2245.   stream = listn (3,
  2246.           fopen_c (fname, "rb"),
  2247.           cons_array (flocons (100), NIL),
  2248.           flocons (0));
  2249.   while (NEQ (stream, form = fast_read (stream)))
  2250.     {
  2251.       if (siod_verbose_level >= 5)
  2252.     lprint (form, NIL);
  2253.       if NULLP
  2254.     (noeval)
  2255.       leval (form, NIL);
  2256.       else
  2257.     result = cons (form, result);
  2258.     }
  2259.   fclose_l (car (stream));
  2260.   if (siod_verbose_level >= 3)
  2261.     put_st ("done.\n");
  2262.   return (nreverse (result));
  2263. }
  2264.  
  2265. static void
  2266. shexstr (char *outstr, void *buff, size_t len)
  2267. {
  2268.   unsigned char *data = buff;
  2269.   size_t j;
  2270.   for (j = 0; j < len; ++j)
  2271.     sprintf (&outstr[j * 2], "%02X", data[j]);
  2272. }
  2273.  
  2274. LISP
  2275. fast_save (LISP fname, LISP forms, LISP nohash, LISP comment)
  2276. {
  2277.   char *cname, msgbuff[100], databuff[50];
  2278.   LISP stream, l;
  2279.   FILE *f;
  2280.   long l_one = 1;
  2281.   double d_one = 1.0;
  2282.   cname = get_c_string (fname);
  2283.   if (siod_verbose_level >= 3)
  2284.     {
  2285.       put_st ("fast saving forms to ");
  2286.       put_st (cname);
  2287.       put_st ("\n");
  2288.     }
  2289.   stream = listn (3,
  2290.           fopen_c (cname, "wb"),
  2291.           NNULLP (nohash) ? NIL : cons_array (flocons (100), NIL),
  2292.           flocons (0));
  2293.   f = get_c_file (car (stream), NULL);
  2294.   if NNULLP
  2295.     (comment)
  2296.       fput_st (f, get_c_string (comment));
  2297.   sprintf (msgbuff, "# Siod Binary Object Save File\n");
  2298.   fput_st (f, msgbuff);
  2299.   sprintf (msgbuff, "# sizeof(long) = %d\n# sizeof(double) = %d\n",
  2300.        sizeof (long), sizeof (double));
  2301.   fput_st (f, msgbuff);
  2302.   shexstr (databuff, &l_one, sizeof (l_one));
  2303.   sprintf (msgbuff, "# 1 = %s\n", databuff);
  2304.   fput_st (f, msgbuff);
  2305.   shexstr (databuff, &d_one, sizeof (d_one));
  2306.   sprintf (msgbuff, "# 1.0 = %s\n", databuff);
  2307.   fput_st (f, msgbuff);
  2308.   for (l = forms; NNULLP (l); l = cdr (l))
  2309.     fast_print (car (l), stream);
  2310.   fclose_l (car (stream));
  2311.   if (siod_verbose_level >= 3)
  2312.     put_st ("done.\n");
  2313.   return (NIL);
  2314. }
  2315.  
  2316. void
  2317. swrite1 (LISP stream, LISP data)
  2318. {
  2319.   FILE *f = get_c_file (stream, stdout);
  2320.   switch TYPE
  2321.     (data)
  2322.     {
  2323.     case tc_symbol:
  2324.     case tc_string:
  2325.       fput_st (f, get_c_string (data));
  2326.       break;
  2327.     default:
  2328.       lprin1f (data, f);
  2329.       break;
  2330.     }
  2331. }
  2332.  
  2333. LISP
  2334. swrite (LISP stream, LISP table, LISP data)
  2335. {
  2336.   LISP value, key;
  2337.   long j, k, m, n;
  2338.   switch (TYPE (data))
  2339.     {
  2340.     case tc_symbol:
  2341.       value = href (table, data);
  2342.       if CONSP
  2343.     (value)
  2344.     {
  2345.       swrite1 (stream, CAR (value));
  2346.       if NNULLP
  2347.         (CDR (value))
  2348.           hset (table, data, CDR (value));
  2349.     }
  2350.       else
  2351.     swrite1 (stream, value);
  2352.       break;
  2353.     case tc_lisp_array:
  2354.       n = data->storage_as.lisp_array.dim;
  2355.       if (n < 1)
  2356.     my_err ("no object repeat count", data);
  2357.       key = data->storage_as.lisp_array.data[0];
  2358.       if NULLP
  2359.     (value = href (table, key))
  2360.       value = key;
  2361.       else if CONSP
  2362.     (value)
  2363.     {
  2364.       if NNULLP
  2365.         (CDR (value))
  2366.           hset (table, key, CDR (value));
  2367.       value = CAR (value);
  2368.     }
  2369.       m = get_c_long (value);
  2370.       for (k = 0; k < m; ++k)
  2371.     for (j = 1; j < n; ++j)
  2372.       swrite (stream, table, data->storage_as.lisp_array.data[j]);
  2373.       break;
  2374.     case tc_cons:
  2375.       /* this should be handled similar to the array case */
  2376.     default:
  2377.       swrite1 (stream, data);
  2378.     }
  2379.   return (NIL);
  2380. }
  2381.  
  2382. LISP
  2383. lpow (LISP x, LISP y)
  2384. {
  2385.   if NFLONUMP
  2386.     (x) my_err ("wta(1st) to pow", x);
  2387.   if NFLONUMP
  2388.     (y) my_err ("wta(2nd) to pow", y);
  2389.   return (flocons (pow (FLONM (x), FLONM (y))));
  2390. }
  2391.  
  2392. LISP
  2393. lexp (LISP x)
  2394. {
  2395.   return (flocons (exp (get_c_double (x))));
  2396. }
  2397.  
  2398. LISP
  2399. llog (LISP x)
  2400. {
  2401.   return (flocons (log (get_c_double (x))));
  2402. }
  2403.  
  2404. LISP
  2405. lsin (LISP x)
  2406. {
  2407.   return (flocons (sin (get_c_double (x))));
  2408. }
  2409.  
  2410. LISP
  2411. lcos (LISP x)
  2412. {
  2413.   return (flocons (cos (get_c_double (x))));
  2414. }
  2415.  
  2416. LISP
  2417. ltan (LISP x)
  2418. {
  2419.   return (flocons (tan (get_c_double (x))));
  2420. }
  2421.  
  2422. LISP
  2423. lasin (LISP x)
  2424. {
  2425.   return (flocons (asin (get_c_double (x))));
  2426. }
  2427.  
  2428. LISP
  2429. lacos (LISP x)
  2430. {
  2431.   return (flocons (acos (get_c_double (x))));
  2432. }
  2433.  
  2434. LISP
  2435. latan (LISP x)
  2436. {
  2437.   return (flocons (atan (get_c_double (x))));
  2438. }
  2439.  
  2440. LISP
  2441. latan2 (LISP x, LISP y)
  2442. {
  2443.   return (flocons (atan2 (get_c_double (x), get_c_double (y))));
  2444. }
  2445.  
  2446. LISP
  2447. hexstr (LISP a)
  2448. {
  2449.   unsigned char *in;
  2450.   char *out;
  2451.   LISP result;
  2452.   long j, dim;
  2453.   in = (unsigned char *) get_c_string_dim (a, &dim);
  2454.   result = strcons (dim * 2, NULL);
  2455.   for (out = get_c_string (result), j = 0; j < dim; ++j, out += 2)
  2456.     sprintf (out, "%02x", in[j]);
  2457.   return (result);
  2458. }
  2459.  
  2460. static int
  2461. xdigitvalue (int c)
  2462. {
  2463.   if (isdigit (c))
  2464.       return (c - '0');
  2465.   if (isxdigit (c))
  2466.       return (toupper (c) - 'A' + 10);
  2467.   return (0);
  2468. }
  2469.  
  2470. LISP
  2471. hexstr2bytes (LISP a)
  2472. {
  2473.   char *in;
  2474.   unsigned char *out;
  2475.   LISP result;
  2476.   long j, dim;
  2477.   in = get_c_string (a);
  2478.   dim = strlen (in) / 2;
  2479.   result = arcons (tc_byte_array, dim, 0);
  2480.   out = (unsigned char *) result->storage_as.string.data;
  2481.   for (j = 0; j < dim; ++j)
  2482.     out[j] = xdigitvalue (in[j * 2]) * 16 + xdigitvalue (in[j * 2 + 1]);
  2483.   return (result);
  2484. }
  2485.  
  2486. LISP
  2487. getprop (LISP plist, LISP key)
  2488. {
  2489.   LISP l;
  2490.   for (l = cdr (plist); NNULLP (l); l = cddr (l))
  2491.     if EQ
  2492.       (car (l), key)
  2493.     return (cadr (l));
  2494.     else
  2495.       INTERRUPT_CHECK ();
  2496.   return (NIL);
  2497. }
  2498.  
  2499. LISP
  2500. setprop (LISP plist, LISP key, LISP value)
  2501. {
  2502.   my_err ("not implemented", NIL);
  2503.   return (NIL);
  2504. }
  2505.  
  2506. LISP
  2507. putprop (LISP plist, LISP value, LISP key)
  2508. {
  2509.   return (setprop (plist, key, value));
  2510. }
  2511.  
  2512. LISP
  2513. ltypeof (LISP obj)
  2514. {
  2515.   long x;
  2516.   x = TYPE (obj);
  2517.   switch (x)
  2518.     {
  2519.     case tc_nil:
  2520.       return (cintern ("tc_nil"));
  2521.     case tc_cons:
  2522.       return (cintern ("tc_cons"));
  2523.     case tc_flonum:
  2524.       return (cintern ("tc_flonum"));
  2525.     case tc_symbol:
  2526.       return (cintern ("tc_symbol"));
  2527.     case tc_subr_0:
  2528.       return (cintern ("tc_subr_0"));
  2529.     case tc_subr_1:
  2530.       return (cintern ("tc_subr_1"));
  2531.     case tc_subr_2:
  2532.       return (cintern ("tc_subr_2"));
  2533.     case tc_subr_2n:
  2534.       return (cintern ("tc_subr_2n"));
  2535.     case tc_subr_3:
  2536.       return (cintern ("tc_subr_3"));
  2537.     case tc_subr_4:
  2538.       return (cintern ("tc_subr_4"));
  2539.     case tc_subr_5:
  2540.       return (cintern ("tc_subr_5"));
  2541.     case tc_lsubr:
  2542.       return (cintern ("tc_lsubr"));
  2543.     case tc_fsubr:
  2544.       return (cintern ("tc_fsubr"));
  2545.     case tc_msubr:
  2546.       return (cintern ("tc_msubr"));
  2547.     case tc_closure:
  2548.       return (cintern ("tc_closure"));
  2549.     case tc_free_cell:
  2550.       return (cintern ("tc_free_cell"));
  2551.     case tc_string:
  2552.       return (cintern ("tc_string"));
  2553.     case tc_byte_array:
  2554.       return (cintern ("tc_byte_array"));
  2555.     case tc_double_array:
  2556.       return (cintern ("tc_double_array"));
  2557.     case tc_long_array:
  2558.       return (cintern ("tc_long_array"));
  2559.     case tc_lisp_array:
  2560.       return (cintern ("tc_lisp_array"));
  2561.     case tc_c_file:
  2562.       return (cintern ("tc_c_file"));
  2563.     default:
  2564.       return (flocons (x));
  2565.     }
  2566. }
  2567.  
  2568. LISP
  2569. caaar (LISP x)
  2570. {
  2571.   return (car (car (car (x))));
  2572. }
  2573.  
  2574. LISP
  2575. caadr (LISP x)
  2576. {
  2577.   return (car (car (cdr (x))));
  2578. }
  2579.  
  2580. LISP
  2581. cadar (LISP x)
  2582. {
  2583.   return (car (cdr (car (x))));
  2584. }
  2585.  
  2586. LISP
  2587. caddr (LISP x)
  2588. {
  2589.   return (car (cdr (cdr (x))));
  2590. }
  2591.  
  2592. LISP
  2593. cdaar (LISP x)
  2594. {
  2595.   return (cdr (car (car (x))));
  2596. }
  2597.  
  2598. LISP
  2599. cdadr (LISP x)
  2600. {
  2601.   return (cdr (car (cdr (x))));
  2602. }
  2603.  
  2604. LISP
  2605. cddar (LISP x)
  2606. {
  2607.   return (cdr (cdr (car (x))));
  2608. }
  2609.  
  2610. LISP
  2611. cdddr (LISP x)
  2612. {
  2613.   return (cdr (cdr (cdr (x))));
  2614. }
  2615.  
  2616. LISP
  2617. ash (LISP value, LISP n)
  2618. {
  2619.   long m, k;
  2620.   m = get_c_long (value);
  2621.   k = get_c_long (n);
  2622.   if (k > 0)
  2623.     m = m << k;
  2624.   else
  2625.     m = m >> (-k);
  2626.   return (flocons (m));
  2627. }
  2628.  
  2629. LISP
  2630. bitand (LISP a, LISP b)
  2631. {
  2632.   return (flocons (get_c_long (a) & get_c_long (b)));
  2633. }
  2634.  
  2635. LISP
  2636. bitor (LISP a, LISP b)
  2637. {
  2638.   return (flocons (get_c_long (a) | get_c_long (b)));
  2639. }
  2640.  
  2641. LISP
  2642. bitxor (LISP a, LISP b)
  2643. {
  2644.   return (flocons (get_c_long (a) ^ get_c_long (b)));
  2645. }
  2646.  
  2647. LISP
  2648. bitnot (LISP a)
  2649. {
  2650.   return (flocons (~get_c_long (a)));
  2651. }
  2652.  
  2653. LISP
  2654. leval_prog1 (LISP args, LISP env)
  2655. {
  2656.   LISP retval, l;
  2657.   retval = leval (car (args), env);
  2658.   for (l = cdr (args); NNULLP (l); l = cdr (l))
  2659.     leval (car (l), env);
  2660.   return (retval);
  2661. }
  2662.  
  2663. LISP
  2664. leval_cond (LISP * pform, LISP * penv)
  2665. {
  2666.   LISP args, env, clause, value, next;
  2667.   args = cdr (*pform);
  2668.   env = *penv;
  2669.   if NULLP
  2670.     (args)
  2671.     {
  2672.       *pform = NIL;
  2673.       return (NIL);
  2674.     }
  2675.   next = cdr (args);
  2676.   while NNULLP
  2677.     (next)
  2678.     {
  2679.       clause = car (args);
  2680.       value = leval (car (clause), env);
  2681.       if NNULLP
  2682.     (value)
  2683.     {
  2684.       clause = cdr (clause);
  2685.       if NULLP
  2686.         (clause)
  2687.         {
  2688.           *pform = value;
  2689.           return (NIL);
  2690.         }
  2691.       else
  2692.         {
  2693.           next = cdr (clause);
  2694.           while (NNULLP (next))
  2695.         {
  2696.           leval (car (clause), env);
  2697.           clause = next;
  2698.           next = cdr (next);
  2699.         }
  2700.           *pform = car (clause);
  2701.           return (sym_t);
  2702.         }
  2703.     }
  2704.       args = next;
  2705.       next = cdr (next);
  2706.     }
  2707.   clause = car (args);
  2708.   next = cdr (clause);
  2709.   if NULLP
  2710.     (next)
  2711.     {
  2712.       *pform = car (clause);
  2713.       return (sym_t);
  2714.     }
  2715.   value = leval (car (clause), env);
  2716.   if NULLP
  2717.     (value)
  2718.     {
  2719.       *pform = NIL;
  2720.       return (NIL);
  2721.     }
  2722.   clause = next;
  2723.   next = cdr (next);
  2724.   while (NNULLP (next))
  2725.     {
  2726.       leval (car (clause), env);
  2727.       clause = next;
  2728.       next = cdr (next);
  2729.     }
  2730.   *pform = car (clause);
  2731.   return (sym_t);
  2732. }
  2733.  
  2734. LISP
  2735. lstrspn (LISP str1, LISP str2)
  2736. {
  2737.   return (flocons (strspn (get_c_string (str1), get_c_string (str2))));
  2738. }
  2739.  
  2740. LISP
  2741. lstrcspn (LISP str1, LISP str2)
  2742. {
  2743.   return (flocons (strcspn (get_c_string (str1), get_c_string (str2))));
  2744. }
  2745.  
  2746. LISP
  2747. substring_equal (LISP str1, LISP str2, LISP start, LISP end)
  2748. {
  2749.   char *cstr1, *cstr2;
  2750.   long len1, n, s, e;
  2751.   cstr1 = get_c_string_dim (str1, &len1);
  2752.   cstr2 = get_c_string_dim (str2, &n);
  2753.   s = NULLP (start) ? 0 : get_c_long (start);
  2754.   e = NULLP (end) ? n : get_c_long (end);
  2755.   if ((s < 0) || (s > e) || (e < 0) || (e > n) || ((e - s) != len1))
  2756.     return (NIL);
  2757.   return ((memcmp (cstr1, &cstr2[s], e - s) == 0) ? a_true_value () : NIL);
  2758. }
  2759.  
  2760. LISP
  2761. set_eval_history (LISP len, LISP circ)
  2762. {
  2763.   LISP data;
  2764.   data = NULLP (len) ? len : make_list (len, NIL);
  2765.   if NNULLP
  2766.     (circ)
  2767.       data = nconc (data, data);
  2768.   setvar (cintern ("*eval-history-ptr*"), data, NIL);
  2769.   setvar (cintern ("*eval-history*"), data, NIL);
  2770.   return (len);
  2771. }
  2772.  
  2773. static LISP
  2774. parser_fasl (LISP ignore)
  2775. {
  2776.   return (closure (listn (3,
  2777.               NIL,
  2778.               cons_array (flocons (100), NIL),
  2779.               flocons (0)),
  2780.            leval (cintern ("parser_fasl_hook"), NIL)));
  2781. }
  2782.  
  2783. static LISP
  2784. parser_fasl_hook (LISP env, LISP f)
  2785. {
  2786.   LISP result;
  2787.   setcar (env, f);
  2788.   result = fast_read (env);
  2789.   if EQ
  2790.     (result, env)
  2791.       return (get_eof_val ());
  2792.   else
  2793.     return (result);
  2794. }
  2795.  
  2796. void
  2797. init_subrs_a (void)
  2798. {
  2799.   init_subr_2 ("aref", aref1);
  2800.   init_subr_3 ("aset", aset1);
  2801.   init_lsubr ("string-append", string_append);
  2802.   init_lsubr ("bytes-append", bytes_append);
  2803.   init_subr_1 ("string-length", string_length);
  2804.   init_subr_1 ("string-dimension", string_dim);
  2805.   init_subr_1 ("read-from-string", read_from_string);
  2806.   init_subr_3 ("print-to-string", print_to_string);
  2807.   init_subr_2 ("cons-array", cons_array);
  2808.   init_subr_2 ("sxhash", sxhash);
  2809.   init_subr_2 ("equal?", equal);
  2810.   init_subr_2 ("href", href);
  2811.   init_subr_3 ("hset", hset);
  2812.   init_subr_2 ("assoc", assoc);
  2813.   init_subr_2 ("assv", assv);
  2814.   init_subr_1 ("fast-read", fast_read);
  2815.   init_subr_2 ("fast-print", fast_print);
  2816.   init_subr_2 ("make-list", make_list);
  2817.   init_subr_2 ("fread", lfread);
  2818.   init_subr_2 ("fwrite", lfwrite);
  2819.   init_subr_1 ("fflush", lfflush);
  2820.   init_subr_1 ("length", llength);
  2821.   init_subr_4 ("number->string", number2string);
  2822.   init_subr_2 ("string->number", string2number);
  2823.   init_subr_3 ("substring", substring);
  2824.   init_subr_2 ("string-search", string_search);
  2825.   init_subr_1 ("string-trim", string_trim);
  2826.   init_subr_1 ("string-trim-left", string_trim_left);
  2827.   init_subr_1 ("string-trim-right", string_trim_right);
  2828.   init_subr_1 ("string-upcase", string_upcase);
  2829.   init_subr_1 ("string-downcase", string_downcase);
  2830.   init_subr_2 ("strcmp", lstrcmp);
  2831.   init_subr_2 ("strcat", lstrcat);
  2832.   init_subr_2 ("strcpy", lstrcpy);
  2833.   init_subr_2 ("strbreakup", lstrbreakup);
  2834.   init_subr_2 ("unbreakupstr", lstrunbreakup);
  2835.   init_subr_1 ("string?", stringp);
  2836.   gc_protect_sym (&sym_e, "e");
  2837.   gc_protect_sym (&sym_f, "f");
  2838.   gc_protect_sym (&sym_plists, "*plists*");
  2839.   setvar (sym_plists, arcons (tc_lisp_array, 100, 1), NIL);
  2840.   init_subr_3 ("lref-default", lref_default);
  2841.   init_subr_3 ("larg-default", larg_default);
  2842.   init_subr_3 ("lkey-default", lkey_default);
  2843.   init_lsubr ("list", llist);
  2844.   init_lsubr ("writes", writes);
  2845.   init_subr_3 ("qsort", lqsort);
  2846.   init_subr_2 ("string-lessp", string_lessp);
  2847.   init_lsubr ("mapcar", mapcar);
  2848.   init_subr_3 ("mapcar2", mapcar2);
  2849.   init_subr_2 ("mapcar1", mapcar1);
  2850.   init_subr_3 ("benchmark-funcall1", benchmark_funcall1);
  2851.   init_lsubr ("benchmark-funcall2", benchmark_funcall2);
  2852.   init_subr_3 ("benchmark-eval", benchmark_eval);
  2853.   init_subr_2 ("fmod", lfmod);
  2854.   init_subr_2 ("subset", lsubset);
  2855.   init_subr_1 ("base64encode", base64encode);
  2856.   init_subr_1 ("base64decode", base64decode);
  2857.   init_subr_3 ("ass", ass);
  2858.   init_subr_2 ("append2", append2);
  2859.   init_lsubr ("append", append);
  2860.   init_subr_4 ("fast-save", fast_save);
  2861.   init_subr_2 ("fast-load", fast_load);
  2862.   init_subr_3 ("swrite", swrite);
  2863.   init_subr_2 ("pow", lpow);
  2864.   init_subr_1 ("exp", lexp);
  2865.   init_subr_1 ("log", llog);
  2866.   init_subr_1 ("sin", lsin);
  2867.   init_subr_1 ("cos", lcos);
  2868.   init_subr_1 ("tan", ltan);
  2869.   init_subr_1 ("asin", lasin);
  2870.   init_subr_1 ("acos", lacos);
  2871.   init_subr_1 ("atan", latan);
  2872.   init_subr_2 ("atan2", latan2);
  2873.   init_subr_1 ("typeof", ltypeof);
  2874.   init_subr_1 ("caaar", caaar);
  2875.   init_subr_1 ("caadr", caadr);
  2876.   init_subr_1 ("cadar", cadar);
  2877.   init_subr_1 ("caddr", caddr);
  2878.   init_subr_1 ("cdaar", cdaar);
  2879.   init_subr_1 ("cdadr", cdadr);
  2880.   init_subr_1 ("cddar", cddar);
  2881.   init_subr_1 ("cdddr", cdddr);
  2882.   setvar (cintern ("*pi*"), flocons (atan (1.0) * 4), NIL);
  2883.   init_base64_table ();
  2884.   init_subr_1 ("array->hexstr", hexstr);
  2885.   init_subr_1 ("hexstr->bytes", hexstr2bytes);
  2886.   init_subr_3 ("ass", ass);
  2887.   init_subr_2 ("bit-and", bitand);
  2888.   init_subr_2 ("bit-or", bitor);
  2889.   init_subr_2 ("bit-xor", bitxor);
  2890.   init_subr_1 ("bit-not", bitnot);
  2891.   init_msubr ("cond", leval_cond);
  2892.   init_fsubr ("prog1", leval_prog1);
  2893.   init_subr_2 ("strspn", lstrspn);
  2894.   init_subr_2 ("strcspn", lstrcspn);
  2895.   init_subr_4 ("substring-equal?", substring_equal);
  2896.   init_subr_1 ("butlast", butlast);
  2897.   init_subr_2 ("ash", ash);
  2898.   init_subr_2 ("get", getprop);
  2899.   init_subr_3 ("setprop", setprop);
  2900.   init_subr_3 ("putprop", putprop);
  2901.   init_subr_1 ("last", last);
  2902.   init_subr_2 ("memq", memq);
  2903.   init_subr_2 ("memv", memv);
  2904.   init_subr_2 ("member", member);
  2905.   init_subr_2 ("nth", nth);
  2906.   init_subr_2 ("nconc", nconc);
  2907.   init_subr_2 ("set-eval-history", set_eval_history);
  2908.   init_subr_1 ("parser_fasl", parser_fasl);
  2909.   setvar (cintern ("*parser_fasl.scm-loaded*"), a_true_value (), NIL);
  2910.   init_subr_2 ("parser_fasl_hook", parser_fasl_hook);
  2911.   init_sliba_version ();
  2912. }
  2913.