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_slib.c < prev    next >
Encoding:
C/C++ Source or Header  |  2000-03-30  |  76.8 KB  |  3,743 lines
  1. /* Scheme In One Defun, but in C this time.
  2.  
  3.  *                      COPYRIGHT (c) 1988-1994 BY                          *
  4.  *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  5.  *                         ALL RIGHTS RESERVED                              *
  6.  
  7.  Permission to use, copy, modify, distribute and sell this software
  8.  and its documentation for any purpose and without fee is hereby
  9.  granted, provided that the above copyright notice appear in all copies
  10.  and that both that copyright notice and this permission notice appear
  11.  in supporting documentation, and that the name of Paradigm Associates
  12.  Inc not be used in advertising or publicity pertaining to distribution
  13.  of the software without specific, written prior permission.
  14.  
  15.  PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  16.  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  17.  PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  18.  ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
  19.  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
  20.  ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  21.  SOFTWARE.
  22.  
  23.  */
  24.  
  25. /*
  26.  
  27.    gjc@world.std.com
  28.  
  29.    Paradigm Associates Inc          Phone: 617-492-6079
  30.    29 Putnam Ave, Suite 6
  31.    Cambridge, MA 02138
  32.  
  33.  
  34.    Release 1.0: 24-APR-88
  35.    Release 1.1: 25-APR-88, added: macros, predicates, load. With additions by
  36.    Barak.Pearlmutter@DOGHEN.BOLTZ.CS.CMU.EDU: Full flonum recognizer,
  37.    cleaned up uses of NULL/0. Now distributed with siod.scm.
  38.    Release 1.2: 28-APR-88, name changes as requested by JAR@AI.AI.MIT.EDU,
  39.    plus some bug fixes.
  40.    Release 1.3: 1-MAY-88, changed env to use frames instead of alist.
  41.    define now works properly. vms specific function edit.
  42.    Release 1.4 20-NOV-89. Minor Cleanup and remodularization.
  43.    Now in 3 files, siod.h, slib.c, siod.c. Makes it easier to write your
  44.    own main loops. Some short-int changes for lightspeed C included.
  45.    Release 1.5 29-NOV-89. Added startup flag -g, select stop and copy
  46.    or mark-and-sweep garbage collection, which assumes that the stack/register
  47.    marking code is correct for your architecture.
  48.    Release 2.0 1-DEC-89. Added repl_hooks, Catch, Throw. This is significantly
  49.    different enough (from 1.3) now that I'm calling it a major release.
  50.    Release 2.1 4-DEC-89. Small reader features, dot, backquote, comma.
  51.    Release 2.2 5-DEC-89. gc,read,print,eval, hooks for user defined datatypes.
  52.    Release 2.3 6-DEC-89. save_forms, obarray intern mechanism. comment char.
  53.    Release 2.3a......... minor speed-ups. i/o interrupt considerations.
  54.    Release 2.4 27-APR-90 gen_readr, for read-from-string.
  55.    Release 2.5 18-SEP-90 arrays added to SIOD.C by popular demand. inums.
  56.    Release 2.6 11-MAR-92 function prototypes, some remodularization.
  57.    Release 2.7 20-MAR-92 hash tables, fasload. Stack check.
  58.    Release 2.8  3-APR-92 Bug fixes, \n syntax in string reading.
  59.    Release 2.9 28-AUG-92 gc sweep bug fix. fseek, ftell, etc. Change to
  60.    envlookup to allow (a . rest) suggested by bowles@is.s.u-tokyo.ac.jp.
  61.    Release 2.9a 10-AUG-93. Minor changes for Windows NT.
  62.    Release 3.0  1-MAY-94. Release it, include changes/cleanup recommended by
  63.    andreasg@nynexst.com for the OS2 C++ compiler. Compilation and running
  64.    tested using DEC C, VAX C. WINDOWS NT. GNU C on SPARC. Storage
  65.    management improvements, more string functions. SQL support.
  66.    Release 3.1? -JUN-95 verbose flag, other integration improvements for htqs.c
  67.    hpux by denson@sdd.hp.com, solaris by pgw9@columbia.edu.
  68.    Release 3.2X MAR-96. dynamic linking, subr closures, other improvements.
  69.  */
  70.  
  71. #include "config.h"
  72.  
  73. #include <stdio.h>
  74. #include <string.h>
  75. #include <ctype.h>
  76. #include <setjmp.h>
  77. #include <signal.h>
  78. #include <math.h>
  79. #include <stdlib.h>
  80. #include <time.h>
  81. #include <errno.h>
  82. #include <sys/types.h>
  83. #if HAVE_SYS_TIMES_H
  84. #include <sys/times.h>
  85. #endif
  86.  
  87. #include <glib.h>
  88.  
  89. #ifdef G_OS_WIN32
  90. #define STRICT
  91. #include <windows.h>
  92. #endif
  93.  
  94. #include "siod.h"
  95. #include "siodp.h"
  96.  
  97. #define MAX_ERROR 1024
  98. char siod_err_msg[MAX_ERROR];
  99.  
  100. static void
  101. init_slib_version (void)
  102. {
  103.   setvar (cintern ("*slib-version*"),
  104.       cintern ("$Id: interp_slib.c,v 1.10 2000/03/28 21:06:35 neo Exp $"),
  105.       NIL);
  106. }
  107.  
  108. char *
  109. siod_version (void)
  110. {
  111.   return ("3.2x 12-MAR-96");
  112. }
  113.  
  114. long nheaps = 2;
  115. LISP *heaps;
  116. LISP heap, heap_end, heap_org;
  117. long heap_size = 5000;
  118. long old_heap_used;
  119. long gc_status_flag = 1;
  120. char *init_file = (char *) NULL;
  121. char *tkbuffer = NULL;
  122. long gc_kind_copying = 0;
  123. long gc_cells_allocated = 0;
  124. double gc_time_taken;
  125. LISP *stack_start_ptr = NULL;
  126. LISP freelist;
  127. jmp_buf errjmp;
  128. long errjmp_ok = 0;
  129. long nointerrupt = 1;
  130. long interrupt_differed = 0;
  131. LISP oblistvar = NIL;
  132. LISP sym_t = NIL;
  133. LISP eof_val = NIL;
  134. LISP sym_errobj = NIL;
  135. LISP sym_catchall = NIL;
  136. LISP sym_progn = NIL;
  137. LISP sym_lambda = NIL;
  138. LISP sym_quote = NIL;
  139. LISP sym_dot = NIL;
  140. LISP sym_after_gc = NIL;
  141. LISP sym_eval_history_ptr = NIL;
  142. LISP unbound_marker = NIL;
  143. LISP *obarray;
  144. LISP repl_return_val = NIL;
  145. long obarray_dim = 100;
  146. struct catch_frame *catch_framep = (struct catch_frame *) NULL;
  147. void (*repl_puts) (char *) = NULL;
  148. LISP (*repl_read) (void) = NULL;
  149. LISP (*repl_eval) (LISP) = NULL;
  150. void (*repl_print) (LISP) = NULL;
  151. LISP *inums;
  152. long inums_dim = 256;
  153. struct user_type_hooks *user_types = NULL;
  154. long user_tc_next = tc_user_min;
  155. struct gc_protected *protected_registers = NULL;
  156. jmp_buf save_regs_gc_mark;
  157. double gc_rt;
  158. long gc_cells_collected;
  159. char *user_ch_readm = "";
  160. char *user_te_readm = "";
  161. LISP (*user_readm) (int, struct gen_readio *) = NULL;
  162. LISP (*user_readt) (char *, long, int *) = NULL;
  163. void (*fatal_exit_hook) (void) = NULL;
  164. #ifdef THINK_C
  165. int ipoll_counter = 0;
  166. #endif
  167.  
  168. char *stack_limit_ptr = NULL;
  169. long stack_size =
  170. #ifdef THINK_C
  171. 10000;
  172. #else
  173. 50000;
  174. #endif
  175.  
  176. long siod_verbose_level = 4;
  177.  
  178. #ifndef SIOD_LIB_DEFAULT
  179. #define SIOD_LIB_DEFAULT "/usr/local/lib/siod"
  180. #endif
  181.  
  182. /*  Added by Spencer Kimball for script-fu shit 6/3/97 */
  183. FILE *siod_output;
  184.  
  185. char *siod_lib = SIOD_LIB_DEFAULT;
  186.  
  187. void
  188. process_cla (int argc, char **argv, int warnflag)
  189. {
  190.   int k;
  191.   char *ptr;
  192.   static int siod_lib_set = 0;
  193. #if !defined(vms)
  194.   if (!siod_lib_set)
  195.     {
  196.       if (getenv ("SIOD_LIB"))
  197.     {
  198.       siod_lib = getenv ("SIOD_LIB");
  199.       siod_lib_set = 1;
  200.     }
  201.     }
  202. #endif
  203.   for (k = 1; k < argc; ++k)
  204.     {
  205.       if (strlen (argv[k]) < 2)
  206.     continue;
  207.       if (argv[k][0] != '-')
  208.     {
  209.       if (warnflag)
  210.         fprintf (stderr, "bad arg: %s\n", argv[k]);
  211.       continue;
  212.     }
  213.       switch (argv[k][1])
  214.     {
  215.     case 'l':
  216.       siod_lib = &argv[k][2];
  217.       break;
  218.     case 'h':
  219.       heap_size = atol (&(argv[k][2]));
  220.       if ((ptr = strchr (&(argv[k][2]), ':')))
  221.         nheaps = atol (&ptr[1]);
  222.       break;
  223.     case 'o':
  224.       obarray_dim = atol (&(argv[k][2]));
  225.       break;
  226.     case 'i':
  227.       init_file = &(argv[k][2]);
  228.       break;
  229.     case 'n':
  230.       inums_dim = atol (&(argv[k][2]));
  231.       break;
  232.     case 'g':
  233.       gc_kind_copying = atol (&(argv[k][2]));
  234.       break;
  235.     case 's':
  236.       stack_size = atol (&(argv[k][2]));
  237.       break;
  238.     case 'v':
  239.       siod_verbose_level = atol (&(argv[k][2]));
  240.       break;
  241.     default:
  242.       if (warnflag)
  243.         fprintf (stderr, "bad arg: %s\n", argv[k]);
  244.     }
  245.     }
  246. }
  247.  
  248. void
  249. print_welcome (void)
  250. {
  251.   if (siod_verbose_level >= 2)
  252.     {
  253.       fprintf (siod_output, "Welcome to SIOD, Scheme In One Defun, Version %s\n",
  254.            siod_version ());
  255.       fprintf (siod_output, "(C) Copyright 1988-1994 Paradigm Associates Inc. Help: (help)\n\n");
  256.       fflush (siod_output);
  257.     }
  258. }
  259.  
  260. void
  261. print_hs_1 (void)
  262. {
  263.   if (siod_verbose_level >= 2)
  264.     {
  265.       fprintf (siod_output, "%ld heaps. size = %ld cells, %ld bytes. %ld inums. GC is %s\n",
  266.            nheaps,
  267.            heap_size, heap_size * sizeof (struct obj),
  268.            inums_dim,
  269.            (gc_kind_copying == 1) ? "stop and copy" : "mark and sweep");
  270.       fflush (siod_output);
  271.     }
  272. }
  273.  
  274. void
  275. print_hs_2 (void)
  276. {
  277.   if (siod_verbose_level >= 2)
  278.     {
  279.       if (gc_kind_copying == 1)
  280.     fprintf (siod_output, "heaps[0] at %p, heaps[1] at %p\n", heaps[0], heaps[1]);
  281.       else
  282.     fprintf (siod_output, "heaps[0] at %p\n", heaps[0]);
  283.       fflush (siod_output);
  284.     }
  285. }
  286.  
  287. long
  288. no_interrupt (long n)
  289. {
  290.   long x;
  291.   x = nointerrupt;
  292.   nointerrupt = n;
  293.   if ((nointerrupt == 0) && (interrupt_differed == 1))
  294.     {
  295.       interrupt_differed = 0;
  296.       err_ctrl_c ();
  297.     }
  298.   return (x);
  299. }
  300.  
  301. void
  302. handle_sigfpe (int sig SIG_restargs)
  303. {
  304.   signal (SIGFPE, handle_sigfpe);
  305.   my_err ("floating point exception", NIL);
  306. }
  307.  
  308. void
  309. handle_sigint (int sig SIG_restargs)
  310. {
  311.   signal (SIGINT, handle_sigint);
  312.   if (nointerrupt == 1)
  313.     interrupt_differed = 1;
  314.   else
  315.     err_ctrl_c ();
  316. }
  317.  
  318. void
  319. err_ctrl_c (void)
  320. {
  321.   my_err ("control-c interrupt", NIL);
  322. }
  323.  
  324. LISP
  325. get_eof_val (void)
  326. {
  327.   return (eof_val);
  328. }
  329.  
  330. long
  331. repl_driver (long want_sigint, long want_init, struct repl_hooks *h)
  332. {
  333.   int k;
  334.   struct repl_hooks hd;
  335.   LISP stack_start;
  336.   stack_start_ptr = &stack_start;
  337.   stack_limit_ptr = STACK_LIMIT (stack_start_ptr, stack_size);
  338.   k = setjmp (errjmp);
  339.   if (k == 2)
  340.     return (2);
  341.   if (want_sigint)
  342.     signal (SIGINT, handle_sigint);
  343.   signal (SIGFPE, handle_sigfpe);
  344.   catch_framep = (struct catch_frame *) NULL;
  345.   errjmp_ok = 1;
  346.   interrupt_differed = 0;
  347.   nointerrupt = 0;
  348.   if (want_init && init_file && (k == 0))
  349.     vload (init_file, 0, 1);
  350.   if (!h)
  351.     {
  352.       hd.repl_puts = repl_puts;
  353.       hd.repl_read = repl_read;
  354.       hd.repl_eval = repl_eval;
  355.       hd.repl_print = repl_print;
  356.       return (repl (&hd));
  357.     }
  358.   else
  359.     return (repl (h));
  360. }
  361.  
  362. static void
  363. ignore_puts (char *st)
  364. {
  365. }
  366.  
  367. static void
  368. noprompt_puts (char *st)
  369. {
  370.   if (strcmp (st, "> ") != 0)
  371.     put_st (st);
  372. }
  373.  
  374. static char *repl_c_string_arg = NULL;
  375. static long repl_c_string_flag = 0;
  376.  
  377. static LISP
  378. repl_c_string_read (void)
  379. {
  380.   LISP s;
  381.   if (repl_c_string_arg == NULL)
  382.     return (get_eof_val ());
  383.   s = strcons (strlen (repl_c_string_arg), repl_c_string_arg);
  384.   repl_c_string_arg = NULL;
  385.   return (read_from_string (s));
  386. }
  387.  
  388. static void
  389. ignore_print (LISP x)
  390. {
  391.   repl_c_string_flag = 1;
  392. }
  393.  
  394. static void
  395. not_ignore_print (LISP x)
  396. {
  397.   repl_c_string_flag = 1;
  398.   lprint (x, NIL);
  399. }
  400.  
  401. long
  402. repl_c_string (char *str,
  403.            long want_sigint, long want_init, long want_print)
  404. {
  405.   struct repl_hooks h;
  406.   long retval;
  407.   if (want_print)
  408.     h.repl_puts = noprompt_puts;
  409.   else
  410.     h.repl_puts = ignore_puts;
  411.   h.repl_read = repl_c_string_read;
  412.   h.repl_eval = NULL;
  413.   if (want_print)
  414.     h.repl_print = not_ignore_print;
  415.   else
  416.     h.repl_print = ignore_print;
  417.   repl_c_string_arg = str;
  418.   repl_c_string_flag = 0;
  419.   retval = repl_driver (want_sigint, want_init, &h);
  420.   if (retval != 0)
  421.     return (retval);
  422.   else if (repl_c_string_flag == 1)
  423.     return (0);
  424.   else
  425.     return (2);
  426. }
  427.  
  428. double
  429. myruntime (void)
  430. {
  431. #if HAVE_SYS_TIMES_H
  432.   double total;
  433.   struct tms b;
  434.   times (&b);
  435.   total = b.tms_utime;
  436.   total += b.tms_stime;
  437.   return (total / 60.0);
  438. #elif defined (G_OS_WIN32)
  439.   FILETIME creation, exit, kernel, user;
  440.   GetProcessTimes (GetCurrentProcess (), &creation, &exit, &kernel, &user);
  441.   return (kernel.dwLowDateTime * 1e7 + user.dwLowDateTime * 1e7);
  442. #endif
  443. }
  444.  
  445. #if defined(__osf__)
  446. #include <sys/timers.h>
  447. #ifndef TIMEOFDAY
  448. #define TIMEOFDAY 1
  449. #endif
  450. double
  451. myrealtime (void)
  452. {
  453.   struct timespec x;
  454.   if (!getclock (TIMEOFDAY, &x))
  455.     return (x.tv_sec + (((double) x.tv_nsec) * 1.0e-9));
  456.   else
  457.     return (0.0);
  458. }
  459. #endif
  460.  
  461. #if defined(VMS)
  462. #include <ssdef.h>
  463. #include <starlet.h>
  464.  
  465. double
  466. myrealtime (void)
  467. {
  468.   unsigned long x[2];
  469.   static double c = 0.0;
  470.   if (sys$gettim (&x) == SS$_NORMAL)
  471.     {
  472.       if (c == 0.0)
  473.     c = pow ((double) 2, (double) 31) * 100.0e-9;
  474.       return (x[0] * 100.0e-9 + x[1] * c);
  475.     }
  476.   else
  477.     return (0.0);
  478. }
  479.  
  480. #endif
  481.  
  482. #if !defined(__osf__) & !defined(VMS)
  483. double
  484. myrealtime (void)
  485. {
  486.   time_t x;
  487.   time (&x);
  488.   return ((double) x);
  489. }
  490. #endif
  491.  
  492. void
  493. set_repl_hooks (void (*puts_f) (char *),
  494.         LISP (*read_f) (void),
  495.         LISP (*eval_f) (LISP),
  496.         void (*print_f) (LISP))
  497. {
  498.   repl_puts = puts_f;
  499.   repl_read = read_f;
  500.   repl_eval = eval_f;
  501.   repl_print = print_f;
  502. }
  503.  
  504. void
  505. gput_st (struct gen_printio *f, char *st)
  506. {
  507.   PUTS_FCN (st, f);
  508. }
  509.  
  510. void
  511. fput_st (FILE * f, char *st)
  512. {
  513.   long flag;
  514.   flag = no_interrupt (1);
  515.   if (siod_verbose_level >= 1)
  516.     {
  517.       fprintf (f, "%s", st);
  518.       fflush (siod_output);
  519.     }
  520.   no_interrupt (flag);
  521. }
  522.  
  523. int
  524. fputs_fcn (char *st, void *cb)
  525. {
  526.   fput_st ((FILE *) cb, st);
  527.   return (1);
  528. }
  529.  
  530. void
  531. put_st (char *st)
  532. {
  533.   fput_st (siod_output, st);
  534.   fflush (siod_output);
  535. }
  536.  
  537. void
  538. grepl_puts (char *st, void (*repl_puts) (char *))
  539. {
  540.   if (repl_puts == NULL)
  541.     put_st (st);
  542.   else
  543.     (*repl_puts) (st);
  544. }
  545.  
  546. long
  547. repl (struct repl_hooks *h)
  548. {
  549.   LISP x, cw = 0;
  550.   double rt, ct;
  551.   while (1)
  552.     {
  553.       if ((gc_kind_copying == 1) && ((gc_status_flag) || heap >= heap_end))
  554.     {
  555.       rt = myruntime ();
  556.       gc_stop_and_copy ();
  557.       if (siod_verbose_level >= 2)
  558.         {
  559.           sprintf (tkbuffer,
  560.                "GC took %g seconds, %ld compressed to %d, %d free\n",
  561.                myruntime () - rt, old_heap_used, (int)(heap - heap_org), (int)(heap_end - heap));
  562.           grepl_puts (tkbuffer, h->repl_puts);
  563.         }
  564.     }
  565.       if (siod_verbose_level >= 2)
  566.     grepl_puts ("> ", h->repl_puts);
  567.       if (h->repl_read == NULL)
  568.     x = lread (NIL);
  569.       else
  570.     x = (*h->repl_read) ();
  571.       if EQ
  572.     (x, eof_val) break;
  573.  
  574.       rt = myruntime ();
  575.       ct = myrealtime ();
  576.       if (gc_kind_copying == 1)
  577.     cw = heap;
  578.       else
  579.     {
  580.       gc_cells_allocated = 0;
  581.       gc_time_taken = 0.0;
  582.     }
  583.       if (h->repl_eval == NULL)
  584.     repl_return_val = x = leval (x, NIL);
  585.       else
  586.     repl_return_val = x = (*h->repl_eval) (x);
  587.       if (gc_kind_copying == 1)
  588.     sprintf (tkbuffer,
  589.          "Evaluation took %g seconds %d cons work, %g real.\n",
  590.          myruntime () - rt,
  591.          (int)(heap - cw),
  592.          myrealtime () - ct);
  593.       else
  594.     sprintf (tkbuffer,
  595.       "Evaluation took %g seconds (%g in gc) %ld cons work, %g real.\n",
  596.          myruntime () - rt,
  597.          gc_time_taken,
  598.          gc_cells_allocated,
  599.          myrealtime () - ct);
  600.       if (siod_verbose_level >= 3)
  601.     grepl_puts (tkbuffer, h->repl_puts);
  602.       if (h->repl_print == NULL)
  603.     {
  604.       if (siod_verbose_level >= 2)
  605.         lprint (x, NIL);
  606.     }
  607.       else
  608.     (*h->repl_print) (x);
  609.     }
  610.  
  611.   return (0);
  612. }
  613.  
  614. void
  615. set_fatal_exit_hook (void (*fcn) (void))
  616. {
  617.   fatal_exit_hook = fcn;
  618. }
  619.  
  620. static long inside_err = 0;
  621.  
  622. LISP
  623. my_err (char *message, LISP x)
  624. {
  625.   struct catch_frame *l;
  626.   long was_inside = inside_err;
  627.   LISP retval, nx;
  628.   char *msg, *eobj;
  629.   nointerrupt = 1;
  630.   if ((!message) && CONSP (x) && TYPEP (CAR (x), tc_string))
  631.     {
  632.       msg = get_c_string (CAR (x));
  633.       nx = CDR (x);
  634.       retval = x;
  635.     }
  636.   else
  637.     {
  638.       msg = message;
  639.       nx = x;
  640.       retval = NIL;
  641.     }
  642.   if ((eobj = try_get_c_string (nx)) && !memchr (eobj, 0, 30))
  643.     eobj = NULL;
  644.  
  645.   if NULLP
  646.     (nx)
  647.       sprintf (siod_err_msg, "ERROR: %s\n", msg);
  648.   else if (eobj)
  649.     sprintf (siod_err_msg, "ERROR: %s (errobj %s)\n", msg, eobj);
  650.   else
  651.     sprintf (siod_err_msg, "ERROR: %s (see errobj)\n", msg);
  652.  
  653.   if ((siod_verbose_level >= 1) && msg)
  654.     {
  655.       fprintf (siod_output, "%s\n", siod_err_msg);
  656.       fflush (siod_output);
  657.     }
  658.   if (errjmp_ok == 1)
  659.     {
  660.       inside_err = 1;
  661.       setvar (sym_errobj, nx, NIL);
  662.       for (l = catch_framep; l; l = (*l).next)
  663.     if (EQ ((*l).tag, sym_errobj) ||
  664.         EQ ((*l).tag, sym_catchall))
  665.       {
  666.         if (!msg)
  667.           msg = "quit";
  668.         (*l).retval = (NNULLP (retval) ? retval :
  669.                (was_inside) ? NIL :
  670.                cons (strcons (strlen (msg), msg), nx));
  671.         nointerrupt = 0;
  672.         inside_err = 0;
  673.         longjmp ((*l).cframe, 2);
  674.       }
  675.       inside_err = 0;
  676.       longjmp (errjmp, (msg) ? 1 : 2);
  677.     }
  678.   if (siod_verbose_level >= 1)
  679.     {
  680.       fprintf (stderr, "FATAL ERROR DURING STARTUP OR CRITICAL CODE SECTION\n");
  681.       fflush (stderr);
  682.     }
  683.   if (fatal_exit_hook)
  684.     (*fatal_exit_hook) ();
  685.   else
  686.     exit (1);
  687.   return (NIL);
  688. }
  689.  
  690. LISP
  691. errswitch (void)
  692. {
  693.   return (my_err ("BUG. Reached impossible case", NIL));
  694. }
  695.  
  696. void
  697. err_stack (char *ptr)
  698.      /* The user could be given an option to continue here */
  699. {
  700.   my_err ("the currently assigned stack limit has been exceded", NIL);
  701. }
  702.  
  703. LISP
  704. stack_limit (LISP amount, LISP silent)
  705. {
  706.   if NNULLP
  707.     (amount)
  708.     {
  709.       stack_size = get_c_long (amount);
  710.       stack_limit_ptr = STACK_LIMIT (stack_start_ptr, stack_size);
  711.     }
  712.   if NULLP
  713.     (silent)
  714.     {
  715.       sprintf (tkbuffer, "Stack_size = %ld bytes, [%p,%p]\n",
  716.            stack_size, stack_start_ptr, stack_limit_ptr);
  717.       put_st (tkbuffer);
  718.       return (NIL);
  719.     }
  720.   else
  721.     return (flocons (stack_size));
  722. }
  723.  
  724. char *
  725. try_get_c_string (LISP x)
  726. {
  727.   if TYPEP
  728.     (x, tc_symbol)
  729.       return (PNAME (x));
  730.   else if TYPEP
  731.     (x, tc_string)
  732.       return (x->storage_as.string.data);
  733.   else
  734.     return (NULL);
  735. }
  736.  
  737. char *
  738. get_c_string (LISP x)
  739. {
  740.   if TYPEP
  741.     (x, tc_symbol)
  742.       return (PNAME (x));
  743.   else if TYPEP
  744.     (x, tc_string)
  745.       return (x->storage_as.string.data);
  746.   else
  747.     my_err ("not a symbol or string", x);
  748.   return (NULL);
  749. }
  750.  
  751. char *
  752. get_c_string_dim (LISP x, long *len)
  753. {
  754.   switch (TYPE (x))
  755.     {
  756.     case tc_symbol:
  757.       *len = strlen (PNAME (x));
  758.       return (PNAME (x));
  759.     case tc_string:
  760.     case tc_byte_array:
  761.       *len = x->storage_as.string.dim;
  762.       return (x->storage_as.string.data);
  763.     case tc_long_array:
  764.       *len = x->storage_as.long_array.dim * sizeof (long);
  765.       return ((char *) x->storage_as.long_array.data);
  766.     default:
  767.       my_err ("not a symbol or string", x);
  768.       return (NULL);
  769.     }
  770. }
  771.  
  772. LISP
  773. lerr (LISP message, LISP x)
  774. {
  775.   if (CONSP (message) && TYPEP (CAR (message), tc_string))
  776.     my_err (NULL, message);
  777.   else
  778.     my_err (get_c_string (message), x);
  779.   return (NIL);
  780. }
  781.  
  782. void
  783. gc_fatal_error (void)
  784. {
  785.   my_err ("ran out of storage", NIL);
  786. }
  787.  
  788. LISP
  789. newcell (long type)
  790. {
  791.   LISP z;
  792.   NEWCELL (z, type);
  793.   return (z);
  794. }
  795.  
  796. LISP
  797. cons (LISP x, LISP y)
  798. {
  799.   LISP z;
  800.   NEWCELL (z, tc_cons);
  801.   CAR (z) = x;
  802.   CDR (z) = y;
  803.   return (z);
  804. }
  805.  
  806. LISP
  807. consp (LISP x)
  808. {
  809.   if CONSP
  810.     (x) return (sym_t);
  811.   else
  812.     return (NIL);
  813. }
  814.  
  815. LISP
  816. car (LISP x)
  817. {
  818.   switch TYPE
  819.     (x)
  820.     {
  821.     case tc_nil:
  822.       return (NIL);
  823.     case tc_cons:
  824.       return (CAR (x));
  825.     default:
  826.       return (my_err ("wta to car", x));
  827.     }
  828. }
  829.  
  830. LISP
  831. cdr (LISP x)
  832. {
  833.   switch TYPE
  834.     (x)
  835.     {
  836.     case tc_nil:
  837.       return (NIL);
  838.     case tc_cons:
  839.       return (CDR (x));
  840.     default:
  841.       return (my_err ("wta to cdr", x));
  842.     }
  843. }
  844.  
  845. LISP
  846. setcar (LISP cell, LISP value)
  847. {
  848.   if NCONSP
  849.     (cell) my_err ("wta to setcar", cell);
  850.   return (CAR (cell) = value);
  851. }
  852.  
  853. LISP
  854. setcdr (LISP cell, LISP value)
  855. {
  856.   if NCONSP
  857.     (cell) my_err ("wta to setcdr", cell);
  858.   return (CDR (cell) = value);
  859. }
  860.  
  861. LISP
  862. flocons (double x)
  863. {
  864.   LISP z;
  865.   long n;
  866.   if ((inums_dim > 0) &&
  867.       ((x - (n = (long) x)) == 0) &&
  868.       (x >= 0) &&
  869.       (n < inums_dim))
  870.     return (inums[n]);
  871.   NEWCELL (z, tc_flonum);
  872.   FLONM (z) = x;
  873.   return (z);
  874. }
  875.  
  876. LISP
  877. numberp (LISP x)
  878. {
  879.   if FLONUMP
  880.     (x) return (sym_t);
  881.   else
  882.     return (NIL);
  883. }
  884.  
  885. LISP
  886. plus (LISP x, LISP y)
  887. {
  888.   if NULLP
  889.     (y)
  890.       return (NULLP (x) ? flocons (0) : x);
  891.   if NFLONUMP
  892.     (x) my_err ("wta(1st) to plus", x);
  893.   if NFLONUMP
  894.     (y) my_err ("wta(2nd) to plus", y);
  895.   return (flocons (FLONM (x) + FLONM (y)));
  896. }
  897.  
  898. LISP
  899. ltimes (LISP x, LISP y)
  900. {
  901.   if NULLP
  902.     (y)
  903.       return (NULLP (x) ? flocons (1) : x);
  904.   if NFLONUMP
  905.     (x) my_err ("wta(1st) to times", x);
  906.   if NFLONUMP
  907.     (y) my_err ("wta(2nd) to times", y);
  908.   return (flocons (FLONM (x) * FLONM (y)));
  909. }
  910.  
  911. LISP
  912. difference (LISP x, LISP y)
  913. {
  914.   if NFLONUMP
  915.     (x) my_err ("wta(1st) to difference", x);
  916.   if NULLP
  917.     (y)
  918.       return (flocons (-FLONM (x)));
  919.   else
  920.     {
  921.       if NFLONUMP
  922.     (y) my_err ("wta(2nd) to difference", y);
  923.       return (flocons (FLONM (x) - FLONM (y)));
  924.     }
  925. }
  926.  
  927. LISP
  928. Quotient (LISP x, LISP y)
  929. {
  930.   if NFLONUMP
  931.     (x) my_err ("wta(1st) to quotient", x);
  932.   if NULLP
  933.     (y)
  934.       return (flocons (1 / FLONM (x)));
  935.   else
  936.     {
  937.       if NFLONUMP
  938.     (y) my_err ("wta(2nd) to quotient", y);
  939.       return (flocons (FLONM (x) / FLONM (y)));
  940.     }
  941. }
  942.  
  943. LISP
  944. lllabs (LISP x)
  945. {
  946.   double v;
  947.   if NFLONUMP
  948.     (x) my_err ("wta to abs", x);
  949.   v = FLONM (x);
  950.   if (v < 0)
  951.     return (flocons (-v));
  952.   else
  953.     return (x);
  954. }
  955.  
  956. LISP
  957. lsqrt (LISP x)
  958. {
  959.   if NFLONUMP
  960.     (x) my_err ("wta to sqrt", x);
  961.   return (flocons (sqrt (FLONM (x))));
  962. }
  963.  
  964. LISP
  965. greaterp (LISP x, LISP y)
  966. {
  967.   if NFLONUMP
  968.     (x) my_err ("wta(1st) to greaterp", x);
  969.   if NFLONUMP
  970.     (y) my_err ("wta(2nd) to greaterp", y);
  971.   if (FLONM (x) > FLONM (y))
  972.     return (sym_t);
  973.   return (NIL);
  974. }
  975.  
  976. LISP
  977. lessp (LISP x, LISP y)
  978. {
  979.   if NFLONUMP
  980.     (x) my_err ("wta(1st) to lessp", x);
  981.   if NFLONUMP
  982.     (y) my_err ("wta(2nd) to lessp", y);
  983.   if (FLONM (x) < FLONM (y))
  984.     return (sym_t);
  985.   return (NIL);
  986. }
  987.  
  988. LISP
  989. greaterEp (LISP x, LISP y)
  990. {
  991.   if NFLONUMP
  992.     (x) my_err ("wta(1st) to greaterp", x);
  993.   if NFLONUMP
  994.     (y) my_err ("wta(2nd) to greaterp", y);
  995.   if (FLONM (x) >= FLONM (y))
  996.     return (sym_t);
  997.   return (NIL);
  998. }
  999.  
  1000. LISP
  1001. lessEp (LISP x, LISP y)
  1002. {
  1003.   if NFLONUMP
  1004.     (x) my_err ("wta(1st) to lessp", x);
  1005.   if NFLONUMP
  1006.     (y) my_err ("wta(2nd) to lessp", y);
  1007.   if (FLONM (x) <= FLONM (y))
  1008.     return (sym_t);
  1009.   return (NIL);
  1010. }
  1011.  
  1012. LISP
  1013. lmax (LISP x, LISP y)
  1014. {
  1015.   if NULLP
  1016.     (y) return (x);
  1017.   if NFLONUMP
  1018.     (x) my_err ("wta(1st) to max", x);
  1019.   if NFLONUMP
  1020.     (y) my_err ("wta(2nd) to max", y);
  1021.   return ((FLONM (x) > FLONM (y)) ? x : y);
  1022. }
  1023.  
  1024. LISP
  1025. lmin (LISP x, LISP y)
  1026. {
  1027.   if NULLP
  1028.     (y) return (x);
  1029.   if NFLONUMP
  1030.     (x) my_err ("wta(1st) to min", x);
  1031.   if NFLONUMP
  1032.     (y) my_err ("wta(2nd) to min", y);
  1033.   return ((FLONM (x) < FLONM (y)) ? x : y);
  1034. }
  1035.  
  1036. LISP
  1037. eq (LISP x, LISP y)
  1038. {
  1039.   if EQ
  1040.     (x, y) return (sym_t);
  1041.   else
  1042.     return (NIL);
  1043. }
  1044.  
  1045. LISP
  1046. eql (LISP x, LISP y)
  1047. {
  1048.   if EQ
  1049.     (x, y) return (sym_t);
  1050.   else if NFLONUMP
  1051.     (x) return (NIL);
  1052.   else if NFLONUMP
  1053.     (y) return (NIL);
  1054.   else if (FLONM (x) == FLONM (y))
  1055.     return (sym_t);
  1056.   return (NIL);
  1057. }
  1058.  
  1059. LISP
  1060. symcons (char *pname, LISP vcell)
  1061. {
  1062.   LISP z;
  1063.   NEWCELL (z, tc_symbol);
  1064.   PNAME (z) = pname;
  1065.   VCELL (z) = vcell;
  1066.   return (z);
  1067. }
  1068.  
  1069. LISP
  1070. symbolp (LISP x)
  1071. {
  1072.   if SYMBOLP
  1073.     (x) return (sym_t);
  1074.   else
  1075.     return (NIL);
  1076. }
  1077.  
  1078. LISP
  1079. err_ubv (LISP v)
  1080. {
  1081.   return (my_err ("unbound variable", v));
  1082. }
  1083.  
  1084. LISP
  1085. symbol_boundp (LISP x, LISP env)
  1086. {
  1087.   LISP tmp;
  1088.   if NSYMBOLP
  1089.     (x) my_err ("not a symbol", x);
  1090.   tmp = envlookup (x, env);
  1091.   if NNULLP
  1092.     (tmp) return (sym_t);
  1093.   if EQ
  1094.     (VCELL (x), unbound_marker) return (NIL);
  1095.   else
  1096.     return (sym_t);
  1097. }
  1098.  
  1099. LISP
  1100. symbol_value (LISP x, LISP env)
  1101. {
  1102.   LISP tmp;
  1103.   if NSYMBOLP
  1104.     (x) my_err ("not a symbol", x);
  1105.   tmp = envlookup (x, env);
  1106.   if NNULLP
  1107.     (tmp) return (CAR (tmp));
  1108.   tmp = VCELL (x);
  1109.   if EQ
  1110.     (tmp, unbound_marker) err_ubv (x);
  1111.   return (tmp);
  1112. }
  1113.  
  1114.  
  1115.  
  1116. char *
  1117. must_malloc (unsigned long size)
  1118. {
  1119.   char *tmp;
  1120.   tmp = (char *) malloc ((size) ? size : 1);
  1121.   if (tmp == (char *) NULL)
  1122.     my_err ("failed to allocate storage from system", NIL);
  1123.   return (tmp);
  1124. }
  1125.  
  1126. LISP
  1127. gen_intern (char *name, long copyp)
  1128. {
  1129.   LISP l, sym, sl;
  1130.   char *cname;
  1131.   long hash = 0, n, c, flag;
  1132.   flag = no_interrupt (1);
  1133.   if (obarray_dim > 1)
  1134.     {
  1135.       hash = 0;
  1136.       n = obarray_dim;
  1137.       cname = name;
  1138.       while ((c = *cname++))
  1139.     hash = ((hash * 17) ^ c) % n;
  1140.       sl = obarray[hash];
  1141.     }
  1142.   else
  1143.     sl = oblistvar;
  1144.   for (l = sl; NNULLP (l); l = CDR (l))
  1145.     if (strcmp (name, PNAME (CAR (l))) == 0)
  1146.       {
  1147.     no_interrupt (flag);
  1148.     return (CAR (l));
  1149.       }
  1150.   if (copyp == 1)
  1151.     {
  1152.       cname = (char *) must_malloc (strlen (name) + 1);
  1153.       strcpy (cname, name);
  1154.     }
  1155.   else
  1156.     cname = name;
  1157.   sym = symcons (cname, unbound_marker);
  1158.   if (obarray_dim > 1)
  1159.     obarray[hash] = cons (sym, sl);
  1160.   oblistvar = cons (sym, oblistvar);
  1161.   no_interrupt (flag);
  1162.   return (sym);
  1163. }
  1164.  
  1165. LISP
  1166. cintern (char *name)
  1167. {
  1168.   return (gen_intern (name, 0));
  1169. }
  1170.  
  1171. LISP
  1172. rintern (char *name)
  1173. {
  1174.   return (gen_intern (name, 1));
  1175. }
  1176.  
  1177. LISP
  1178. intern (LISP name)
  1179. {
  1180.   return (rintern (get_c_string (name)));
  1181. }
  1182.  
  1183. LISP
  1184. subrcons (long type, char *name, SUBR_FUNC f)
  1185. {
  1186.   LISP z;
  1187.   NEWCELL (z, type);
  1188.   (*z).storage_as.subr.name = name;
  1189.   (*z).storage_as.subr0.f = f;
  1190.   return (z);
  1191. }
  1192.  
  1193. LISP
  1194. closure (LISP env, LISP code)
  1195. {
  1196.   LISP z;
  1197.   NEWCELL (z, tc_closure);
  1198.   (*z).storage_as.closure.env = env;
  1199.   (*z).storage_as.closure.code = code;
  1200.   return (z);
  1201. }
  1202.  
  1203. void
  1204. gc_protect (LISP * location)
  1205. {
  1206.   gc_protect_n (location, 1);
  1207. }
  1208.  
  1209. void
  1210. gc_protect_n (LISP * location, long n)
  1211. {
  1212.   struct gc_protected *reg;
  1213.   reg = (struct gc_protected *) must_malloc (sizeof (struct gc_protected));
  1214.   (*reg).location = location;
  1215.   (*reg).length = n;
  1216.   (*reg).next = protected_registers;
  1217.   protected_registers = reg;
  1218. }
  1219.  
  1220. void
  1221. gc_protect_sym (LISP * location, char *st)
  1222. {
  1223.   *location = cintern (st);
  1224.   gc_protect (location);
  1225. }
  1226.  
  1227. void
  1228. gc_unprotect (LISP * location)
  1229. {
  1230.   struct gc_protected *reg;
  1231.   struct gc_protected *prev_reg;
  1232.  
  1233.   prev_reg = NULL;
  1234.   reg = protected_registers;
  1235.  
  1236.   while (reg)
  1237.     {
  1238.       if (location == reg->location)
  1239.     {
  1240.       if (prev_reg)
  1241.         prev_reg->next = reg->next;
  1242.       if (reg == protected_registers)
  1243.         protected_registers = protected_registers->next;
  1244.  
  1245.       free (reg);
  1246.       break;
  1247.     }
  1248.  
  1249.       prev_reg = reg;
  1250.       reg = reg->next;
  1251.     }
  1252. }
  1253.  
  1254. void
  1255. scan_registers (void)
  1256. {
  1257.   struct gc_protected *reg;
  1258.   LISP *location;
  1259.   long j, n;
  1260.  
  1261.   for (reg = protected_registers; reg; reg = (*reg).next)
  1262.     {
  1263.       location = (*reg).location;
  1264.       n = (*reg).length;
  1265.       for (j = 0; j < n; ++j)
  1266.     location[j] = gc_relocate (location[j]);
  1267.     }
  1268. }
  1269.  
  1270. void
  1271. init_storage (void)
  1272. {
  1273.   long j;
  1274.   LISP stack_start;
  1275.   if (stack_start_ptr == NULL)
  1276.     stack_start_ptr = &stack_start;
  1277.   init_storage_1 ();
  1278.   init_storage_a ();
  1279.   set_gc_hooks (tc_c_file, 0, 0, 0, file_gc_free, &j);
  1280.   set_print_hooks (tc_c_file, file_prin1);
  1281. }
  1282.  
  1283. void
  1284. init_storage_1 (void)
  1285. {
  1286.   LISP ptr;
  1287.   long j;
  1288.   tkbuffer = (char *) must_malloc (TKBUFFERN + 1);
  1289.   if (((gc_kind_copying == 1) && (nheaps != 2)) || (nheaps < 1))
  1290.     my_err ("invalid number of heaps", NIL);
  1291.   heaps = (LISP *) must_malloc (sizeof (LISP) * nheaps);
  1292.   for (j = 0; j < nheaps; ++j)
  1293.     heaps[j] = NULL;
  1294.   heaps[0] = (LISP) must_malloc (sizeof (struct obj) * heap_size);
  1295.   heap = heaps[0];
  1296.   heap_org = heap;
  1297.   heap_end = heap + heap_size;
  1298.   if (gc_kind_copying == 1)
  1299.     heaps[1] = (LISP) must_malloc (sizeof (struct obj) * heap_size);
  1300.   else
  1301.     freelist = NIL;
  1302.   gc_protect (&oblistvar);
  1303.   if (obarray_dim > 1)
  1304.     {
  1305.       obarray = (LISP *) must_malloc (sizeof (LISP) * obarray_dim);
  1306.       for (j = 0; j < obarray_dim; ++j)
  1307.     obarray[j] = NIL;
  1308.       gc_protect_n (obarray, obarray_dim);
  1309.     }
  1310.   unbound_marker = cons (cintern ("**unbound-marker**"), NIL);
  1311.   gc_protect (&unbound_marker);
  1312.   eof_val = cons (cintern ("eof"), NIL);
  1313.   gc_protect (&eof_val);
  1314.   gc_protect_sym (&sym_t, "t");
  1315.   setvar (sym_t, sym_t, NIL);
  1316.   setvar (cintern ("nil"), NIL, NIL);
  1317.   setvar (cintern ("let"), cintern ("let-internal-macro"), NIL);
  1318.   setvar (cintern ("let*"), cintern ("let*-macro"), NIL);
  1319.   setvar (cintern ("letrec"), cintern ("letrec-macro"), NIL);
  1320.   gc_protect_sym (&sym_errobj, "errobj");
  1321.   setvar (sym_errobj, NIL, NIL);
  1322.   gc_protect_sym (&sym_catchall, "all");
  1323.   gc_protect_sym (&sym_progn, "begin");
  1324.   gc_protect_sym (&sym_lambda, "lambda");
  1325.   gc_protect_sym (&sym_quote, "quote");
  1326.   gc_protect_sym (&sym_dot, ".");
  1327.   gc_protect_sym (&sym_after_gc, "*after-gc*");
  1328.   setvar (sym_after_gc, NIL, NIL);
  1329.   gc_protect_sym (&sym_eval_history_ptr, "*eval-history-ptr*");
  1330.   setvar (sym_eval_history_ptr, NIL, NIL);
  1331.   if (inums_dim > 0)
  1332.     {
  1333.       inums = (LISP *) must_malloc (sizeof (LISP) * inums_dim);
  1334.       for (j = 0; j < inums_dim; ++j)
  1335.     {
  1336.       NEWCELL (ptr, tc_flonum);
  1337.       FLONM (ptr) = j;
  1338.       inums[j] = ptr;
  1339.     }
  1340.       gc_protect_n (inums, inums_dim);
  1341.     }
  1342. }
  1343.  
  1344. void
  1345. init_subr (char *name, long type, SUBR_FUNC fcn)
  1346. {
  1347.   setvar (cintern (name), subrcons (type, name, fcn), NIL);
  1348. }
  1349.  
  1350. void
  1351. init_subr_0 (char *name, LISP (*fcn) (void))
  1352. {
  1353.   init_subr (name, tc_subr_0, (SUBR_FUNC) fcn);
  1354. }
  1355.  
  1356. void
  1357. init_subr_1 (char *name, LISP (*fcn) (LISP))
  1358. {
  1359.   init_subr (name, tc_subr_1, (SUBR_FUNC) fcn);
  1360. }
  1361.  
  1362. void
  1363. init_subr_2 (char *name, LISP (*fcn) (LISP, LISP))
  1364. {
  1365.   init_subr (name, tc_subr_2, (SUBR_FUNC) fcn);
  1366. }
  1367.  
  1368. void
  1369. init_subr_2n (char *name, LISP (*fcn) (LISP, LISP))
  1370. {
  1371.   init_subr (name, tc_subr_2n, (SUBR_FUNC) fcn);
  1372. }
  1373.  
  1374. void
  1375. init_subr_3 (char *name, LISP (*fcn) (LISP, LISP, LISP))
  1376. {
  1377.   init_subr (name, tc_subr_3, (SUBR_FUNC) fcn);
  1378. }
  1379.  
  1380. void
  1381. init_subr_4 (char *name, LISP (*fcn) (LISP, LISP, LISP, LISP))
  1382. {
  1383.   init_subr (name, tc_subr_4, (SUBR_FUNC) fcn);
  1384. }
  1385.  
  1386. void
  1387. init_subr_5 (char *name, LISP (*fcn) (LISP, LISP, LISP, LISP, LISP))
  1388. {
  1389.   init_subr (name, tc_subr_5, (SUBR_FUNC) fcn);
  1390. }
  1391.  
  1392. void
  1393. init_lsubr (char *name, LISP (*fcn) (LISP))
  1394. {
  1395.   init_subr (name, tc_lsubr, (SUBR_FUNC) fcn);
  1396. }
  1397.  
  1398. void
  1399. init_fsubr (char *name, LISP (*fcn) (LISP, LISP))
  1400. {
  1401.   init_subr (name, tc_fsubr, (SUBR_FUNC) fcn);
  1402. }
  1403.  
  1404. void
  1405. init_msubr (char *name, LISP (*fcn) (LISP *, LISP *))
  1406. {
  1407.   init_subr (name, tc_msubr, (SUBR_FUNC) fcn);
  1408. }
  1409.  
  1410. LISP
  1411. assq (LISP x, LISP alist)
  1412. {
  1413.   LISP l, tmp;
  1414.   for (l = alist; CONSP (l); l = CDR (l))
  1415.     {
  1416.       tmp = CAR (l);
  1417.       if (CONSP (tmp) && EQ (CAR (tmp), x))
  1418.     return (tmp);
  1419.       INTERRUPT_CHECK ();
  1420.     }
  1421.   if EQ
  1422.     (l, NIL) return (NIL);
  1423.   return (my_err ("improper list to assq", alist));
  1424. }
  1425.  
  1426.  
  1427. struct user_type_hooks *
  1428. get_user_type_hooks (long type)
  1429. {
  1430.   long n;
  1431.   if (user_types == NULL)
  1432.     {
  1433.       n = sizeof (struct user_type_hooks) * tc_table_dim;
  1434.       user_types = (struct user_type_hooks *) must_malloc (n);
  1435.       memset (user_types, 0, n);
  1436.     }
  1437.   if ((type >= 0) && (type < tc_table_dim))
  1438.     return (&user_types[type]);
  1439.   else
  1440.     my_err ("type number out of range", NIL);
  1441.   return (NULL);
  1442. }
  1443.  
  1444. long
  1445. allocate_user_tc (void)
  1446. {
  1447.   long x = user_tc_next;
  1448.   if (x > tc_user_max)
  1449.     my_err ("ran out of user type codes", NIL);
  1450.   ++user_tc_next;
  1451.   return (x);
  1452. }
  1453.  
  1454. void
  1455. set_gc_hooks (long type,
  1456.           LISP (*rel) (LISP),
  1457.           LISP (*mark) (LISP),
  1458.           void (*scan) (LISP),
  1459.           void (*free) (LISP),
  1460.           long *kind)
  1461. {
  1462.   struct user_type_hooks *p;
  1463.   p = get_user_type_hooks (type);
  1464.   p->gc_relocate = rel;
  1465.   p->gc_scan = scan;
  1466.   p->gc_mark = mark;
  1467.   p->gc_free = free;
  1468.   *kind = gc_kind_copying;
  1469. }
  1470.  
  1471. LISP
  1472. gc_relocate (LISP x)
  1473. {
  1474.   LISP nw;
  1475.   struct user_type_hooks *p;
  1476.   if EQ
  1477.     (x, NIL) return (NIL);
  1478.   if ((*x).gc_mark == 1)
  1479.     return (CAR (x));
  1480.   switch TYPE
  1481.     (x)
  1482.     {
  1483.     case tc_flonum:
  1484.     case tc_cons:
  1485.     case tc_symbol:
  1486.     case tc_closure:
  1487.     case tc_subr_0:
  1488.     case tc_subr_1:
  1489.     case tc_subr_2:
  1490.     case tc_subr_2n:
  1491.     case tc_subr_3:
  1492.     case tc_subr_4:
  1493.     case tc_subr_5:
  1494.     case tc_lsubr:
  1495.     case tc_fsubr:
  1496.     case tc_msubr:
  1497.       if ((nw = heap) >= heap_end)
  1498.     gc_fatal_error ();
  1499.       heap = nw + 1;
  1500.       memcpy (nw, x, sizeof (struct obj));
  1501.       break;
  1502.     default:
  1503.       p = get_user_type_hooks (TYPE (x));
  1504.       if (p->gc_relocate)
  1505.     nw = (*p->gc_relocate) (x);
  1506.       else
  1507.     {
  1508.       if ((nw = heap) >= heap_end)
  1509.         gc_fatal_error ();
  1510.       heap = nw + 1;
  1511.       memcpy (nw, x, sizeof (struct obj));
  1512.     }
  1513.     }
  1514.   (*x).gc_mark = 1;
  1515.   CAR (x) = nw;
  1516.   return (nw);
  1517. }
  1518.  
  1519. LISP
  1520. get_newspace (void)
  1521. {
  1522.   LISP newspace;
  1523.   if (heap_org == heaps[0])
  1524.     newspace = heaps[1];
  1525.   else
  1526.     newspace = heaps[0];
  1527.   heap = newspace;
  1528.   heap_org = heap;
  1529.   heap_end = heap + heap_size;
  1530.   return (newspace);
  1531. }
  1532.  
  1533. void
  1534. scan_newspace (LISP newspace)
  1535. {
  1536.   LISP ptr;
  1537.   struct user_type_hooks *p;
  1538.   for (ptr = newspace; ptr < heap; ++ptr)
  1539.     {
  1540.       switch TYPE
  1541.     (ptr)
  1542.     {
  1543.     case tc_cons:
  1544.     case tc_closure:
  1545.       CAR (ptr) = gc_relocate (CAR (ptr));
  1546.       CDR (ptr) = gc_relocate (CDR (ptr));
  1547.       break;
  1548.     case tc_symbol:
  1549.       VCELL (ptr) = gc_relocate (VCELL (ptr));
  1550.       break;
  1551.     case tc_flonum:
  1552.     case tc_subr_0:
  1553.     case tc_subr_1:
  1554.     case tc_subr_2:
  1555.     case tc_subr_2n:
  1556.     case tc_subr_3:
  1557.     case tc_subr_4:
  1558.     case tc_subr_5:
  1559.     case tc_lsubr:
  1560.     case tc_fsubr:
  1561.     case tc_msubr:
  1562.       break;
  1563.     default:
  1564.       p = get_user_type_hooks (TYPE (ptr));
  1565.       if (p->gc_scan)
  1566.         (*p->gc_scan) (ptr);
  1567.     }
  1568.     }
  1569. }
  1570.  
  1571. void
  1572. free_oldspace (LISP space, LISP end)
  1573. {
  1574.   LISP ptr;
  1575.   struct user_type_hooks *p;
  1576.   for (ptr = space; ptr < end; ++ptr)
  1577.     if (ptr->gc_mark == 0)
  1578.       switch TYPE
  1579.     (ptr)
  1580.     {
  1581.     case tc_cons:
  1582.     case tc_closure:
  1583.     case tc_symbol:
  1584.     case tc_flonum:
  1585.     case tc_subr_0:
  1586.     case tc_subr_1:
  1587.     case tc_subr_2:
  1588.     case tc_subr_2n:
  1589.     case tc_subr_3:
  1590.     case tc_subr_4:
  1591.     case tc_subr_5:
  1592.     case tc_lsubr:
  1593.     case tc_fsubr:
  1594.     case tc_msubr:
  1595.       break;
  1596.     default:
  1597.       p = get_user_type_hooks (TYPE (ptr));
  1598.       if (p->gc_free)
  1599.         (*p->gc_free) (ptr);
  1600.     }
  1601. }
  1602.  
  1603. void
  1604. gc_stop_and_copy (void)
  1605. {
  1606.   LISP newspace, oldspace, end;
  1607.   long flag;
  1608.   flag = no_interrupt (1);
  1609.   errjmp_ok = 0;
  1610.   oldspace = heap_org;
  1611.   end = heap;
  1612.   old_heap_used = end - oldspace;
  1613.   newspace = get_newspace ();
  1614.   scan_registers ();
  1615.   scan_newspace (newspace);
  1616.   free_oldspace (oldspace, end);
  1617.   errjmp_ok = 1;
  1618.   no_interrupt (flag);
  1619. }
  1620.  
  1621. LISP
  1622. allocate_aheap (void)
  1623. {
  1624.   long j, flag;
  1625.   LISP ptr, end, next;
  1626.   gc_kind_check ();
  1627.   for (j = 0; j < nheaps; ++j)
  1628.     if (!heaps[j])
  1629.       {
  1630.     flag = no_interrupt (1);
  1631.     if (gc_status_flag && (siod_verbose_level >= 4))
  1632.       fprintf (siod_output, "[allocating heap %ld]\n", j);
  1633.     heaps[j] = (LISP) must_malloc (sizeof (struct obj) * heap_size);
  1634.     ptr = heaps[j];
  1635.     end = heaps[j] + heap_size;
  1636.     while (1)
  1637.       {
  1638.         (*ptr).type = tc_free_cell;
  1639.         next = ptr + 1;
  1640.         if (next < end)
  1641.           {
  1642.         CDR (ptr) = next;
  1643.         ptr = next;
  1644.           }
  1645.         else
  1646.           {
  1647.         CDR (ptr) = freelist;
  1648.         break;
  1649.           }
  1650.       }
  1651.     freelist = heaps[j];
  1652.     flag = no_interrupt (flag);
  1653.     return (sym_t);
  1654.       }
  1655.   return (NIL);
  1656. }
  1657.  
  1658. void
  1659. gc_for_newcell (void)
  1660. {
  1661.   long flag, n;
  1662.   LISP l;
  1663.   if (heap < heap_end)
  1664.     {
  1665.       freelist = heap;
  1666.       CDR (freelist) = NIL;
  1667.       ++heap;
  1668.       return;
  1669.     }
  1670.   if (errjmp_ok == 0)
  1671.     gc_fatal_error ();
  1672.   flag = no_interrupt (1);
  1673.   errjmp_ok = 0;
  1674.   gc_mark_and_sweep ();
  1675.   errjmp_ok = 1;
  1676.   no_interrupt (flag);
  1677.   for (n = 0, l = freelist; (n < 100) && NNULLP (l); ++n)
  1678.     l = CDR (l);
  1679.   if (n == 0)
  1680.     {
  1681.       if NULLP
  1682.     (allocate_aheap ())
  1683.       gc_fatal_error ();
  1684.     }
  1685.   else if ((n == 100) && NNULLP (sym_after_gc))
  1686.     leval (leval (sym_after_gc, NIL), NIL);
  1687.   else
  1688.     allocate_aheap ();
  1689. }
  1690.  
  1691. void
  1692. gc_mark_and_sweep (void)
  1693. {
  1694.   LISP stack_end;
  1695.   gc_ms_stats_start ();
  1696.   while (heap < heap_end)
  1697.     {
  1698.       heap->type = tc_free_cell;
  1699.       heap->gc_mark = 0;
  1700.       ++heap;
  1701.     }
  1702.   setjmp (save_regs_gc_mark);
  1703.   mark_locations ((LISP *) save_regs_gc_mark,
  1704.       (LISP *) (((char *) save_regs_gc_mark) + sizeof (save_regs_gc_mark)));
  1705.   mark_protected_registers ();
  1706.   mark_locations ((LISP *) stack_start_ptr,
  1707.           (LISP *) & stack_end);
  1708. #ifdef THINK_C
  1709.   mark_locations ((LISP *) ((char *) stack_start_ptr + 2),
  1710.           (LISP *) ((char *) &stack_end + 2));
  1711. #endif
  1712.   gc_sweep ();
  1713.   gc_ms_stats_end ();
  1714. }
  1715.  
  1716. void
  1717. gc_ms_stats_start (void)
  1718. {
  1719.   gc_rt = myruntime ();
  1720.   gc_cells_collected = 0;
  1721.   if (gc_status_flag && (siod_verbose_level >= 4))
  1722.     fprintf (siod_output, "[starting GC]\n");
  1723. }
  1724.  
  1725. void
  1726. gc_ms_stats_end (void)
  1727. {
  1728.   gc_rt = myruntime () - gc_rt;
  1729.   gc_time_taken = gc_time_taken + gc_rt;
  1730.   if (gc_status_flag && (siod_verbose_level >= 4))
  1731.     fprintf (siod_output, "[GC took %g cpu seconds, %ld cells collected]\n",
  1732.          gc_rt,
  1733.          gc_cells_collected);
  1734. }
  1735.  
  1736. void
  1737. gc_mark (LISP ptr)
  1738. {
  1739.   struct user_type_hooks *p;
  1740. gc_mark_loop:
  1741.   if NULLP
  1742.     (ptr) return;
  1743.   if ((*ptr).gc_mark)
  1744.     return;
  1745.   (*ptr).gc_mark = 1;
  1746.   switch ((*ptr).type)
  1747.     {
  1748.     case tc_flonum:
  1749.       break;
  1750.     case tc_cons:
  1751.       gc_mark (CAR (ptr));
  1752.       ptr = CDR (ptr);
  1753.       goto gc_mark_loop;
  1754.     case tc_symbol:
  1755.       ptr = VCELL (ptr);
  1756.       goto gc_mark_loop;
  1757.     case tc_closure:
  1758.       gc_mark ((*ptr).storage_as.closure.code);
  1759.       ptr = (*ptr).storage_as.closure.env;
  1760.       goto gc_mark_loop;
  1761.     case tc_subr_0:
  1762.     case tc_subr_1:
  1763.     case tc_subr_2:
  1764.     case tc_subr_2n:
  1765.     case tc_subr_3:
  1766.     case tc_subr_4:
  1767.     case tc_subr_5:
  1768.     case tc_lsubr:
  1769.     case tc_fsubr:
  1770.     case tc_msubr:
  1771.       break;
  1772.     default:
  1773.       p = get_user_type_hooks (TYPE (ptr));
  1774.       if (p->gc_mark)
  1775.     ptr = (*p->gc_mark) (ptr);
  1776.     }
  1777. }
  1778.  
  1779. void
  1780. mark_protected_registers (void)
  1781. {
  1782.   struct gc_protected *reg;
  1783.   LISP *location;
  1784.   long j, n;
  1785.   for (reg = protected_registers; reg; reg = (*reg).next)
  1786.     {
  1787.       location = (*reg).location;
  1788.       n = (*reg).length;
  1789.       for (j = 0; j < n; ++j)
  1790.     gc_mark (location[j]);
  1791.     }
  1792. }
  1793.  
  1794. void
  1795. mark_locations (LISP * start, LISP * end)
  1796. {
  1797.   LISP *tmp;
  1798.   long n;
  1799.   if (start > end)
  1800.     {
  1801.       tmp = start;
  1802.       start = end;
  1803.       end = tmp;
  1804.     }
  1805.   n = end - start;
  1806.   mark_locations_array (start, n);
  1807. }
  1808.  
  1809. long
  1810. looks_pointerp (LISP p)
  1811. {
  1812.   long j;
  1813.   LISP h;
  1814.   for (j = 0; j < nheaps; ++j)
  1815.     if ((h = heaps[j]) &&
  1816.     (p >= h) &&
  1817.     (p < (h + heap_size)) &&
  1818.     (((((char *) p) - ((char *) h)) % sizeof (struct obj)) == 0) &&
  1819.     NTYPEP (p, tc_free_cell))
  1820.         return (1);
  1821.   return (0);
  1822. }
  1823.  
  1824. void
  1825. mark_locations_array (LISP * x, long n)
  1826. {
  1827.   int j;
  1828.   LISP p;
  1829.   for (j = 0; j < n; ++j)
  1830.     {
  1831.       p = x[j];
  1832.       if (looks_pointerp (p))
  1833.     gc_mark (p);
  1834.     }
  1835. }
  1836.  
  1837. void
  1838. gc_sweep (void)
  1839. {
  1840.   LISP ptr, end, nfreelist, org;
  1841.   long n, k;
  1842.   struct user_type_hooks *p;
  1843.   end = heap_end;
  1844.   n = 0;
  1845.   nfreelist = NIL;
  1846.   for (k = 0; k < nheaps; ++k)
  1847.     if (heaps[k])
  1848.       {
  1849.     org = heaps[k];
  1850.     end = org + heap_size;
  1851.     for (ptr = org; ptr < end; ++ptr)
  1852.       if (((*ptr).gc_mark == 0))
  1853.         {
  1854.           switch ((*ptr).type)
  1855.         {
  1856.         case tc_free_cell:
  1857.         case tc_cons:
  1858.         case tc_closure:
  1859.         case tc_symbol:
  1860.         case tc_flonum:
  1861.         case tc_subr_0:
  1862.         case tc_subr_1:
  1863.         case tc_subr_2:
  1864.         case tc_subr_2n:
  1865.         case tc_subr_3:
  1866.         case tc_subr_4:
  1867.         case tc_subr_5:
  1868.         case tc_lsubr:
  1869.         case tc_fsubr:
  1870.         case tc_msubr:
  1871.           break;
  1872.         default:
  1873.           p = get_user_type_hooks (TYPE (ptr));
  1874.           if (p->gc_free)
  1875.             (*p->gc_free) (ptr);
  1876.         }
  1877.           ++n;
  1878.           (*ptr).type = tc_free_cell;
  1879.           CDR (ptr) = nfreelist;
  1880.           nfreelist = ptr;
  1881.         }
  1882.       else
  1883.         (*ptr).gc_mark = 0;
  1884.       }
  1885.   gc_cells_collected = n;
  1886.   freelist = nfreelist;
  1887. }
  1888.  
  1889. void
  1890. gc_kind_check (void)
  1891. {
  1892.   if (gc_kind_copying == 1)
  1893.     my_err ("cannot perform operation with stop-and-copy GC mode. Use -g0\n",
  1894.      NIL);
  1895. }
  1896.  
  1897. LISP
  1898. user_gc (LISP args)
  1899. {
  1900.   long old_status_flag, flag;
  1901.   gc_kind_check ();
  1902.   flag = no_interrupt (1);
  1903.   errjmp_ok = 0;
  1904.   old_status_flag = gc_status_flag;
  1905.   if NNULLP (args)
  1906.     {
  1907.       if NULLP (car (args)) 
  1908.       gc_status_flag = 0;
  1909.       else
  1910.     gc_status_flag = 1;
  1911.     }
  1912.   gc_mark_and_sweep ();
  1913.   gc_status_flag = old_status_flag;
  1914.   errjmp_ok = 1;
  1915.   no_interrupt (flag);
  1916.   return (NIL);
  1917. }
  1918.  
  1919. long
  1920. nactive_heaps (void)
  1921. {
  1922.   long m;
  1923.   for (m = 0; (m < nheaps) && heaps[m]; ++m);
  1924.   return (m);
  1925. }
  1926.  
  1927. long
  1928. freelist_length (void)
  1929. {
  1930.   long n;
  1931.   LISP l;
  1932.   for (n = 0, l = freelist; NNULLP (l); ++n)
  1933.     l = CDR (l);
  1934.   n += (heap_end - heap);
  1935.   return (n);
  1936. }
  1937.  
  1938. LISP
  1939. gc_status (LISP args)
  1940. {
  1941.   long n, m;
  1942.   if NNULLP (args)
  1943.     {
  1944.       if NULLP (car (args)) 
  1945.     gc_status_flag = 0;
  1946.       else
  1947.     gc_status_flag = 1;
  1948.     }
  1949.   
  1950.   if (gc_kind_copying == 1)
  1951.     {
  1952.       if (gc_status_flag)
  1953.     put_st ("garbage collection is on\n");
  1954.       else
  1955.     put_st ("garbage collection is off\n");
  1956.       sprintf (tkbuffer, "%d allocated %d free\n",
  1957.            (int)(heap - heap_org), (int)(heap_end - heap));
  1958.       put_st (tkbuffer);
  1959.     }
  1960.   else
  1961.     {
  1962.       if (gc_status_flag)
  1963.     put_st ("garbage collection verbose\n");
  1964.       else
  1965.     put_st ("garbage collection silent\n");
  1966.       {
  1967.     m = nactive_heaps ();
  1968.     n = freelist_length ();
  1969.     sprintf (tkbuffer, "%ld/%ld heaps, %ld allocated %ld free\n",
  1970.          m, nheaps, m * heap_size - n, n);
  1971.     put_st (tkbuffer);
  1972.       }
  1973.     }
  1974.   return (NIL);
  1975. }
  1976.  
  1977. LISP
  1978. gc_info (LISP arg)
  1979. {
  1980.   switch (get_c_long (arg))
  1981.     {
  1982.     case 0:
  1983.       return ((gc_kind_copying == 1) ? sym_t : NIL);
  1984.     case 1:
  1985.       return (flocons (nactive_heaps ()));
  1986.     case 2:
  1987.       return (flocons (nheaps));
  1988.     case 3:
  1989.       return (flocons (heap_size));
  1990.     case 4:
  1991.       return (flocons ((gc_kind_copying == 1)
  1992.                ? (long) (heap_end - heap)
  1993.                : freelist_length ()));
  1994.     default:
  1995.       return (NIL);
  1996.     }
  1997. }
  1998.  
  1999. LISP
  2000. leval_args (LISP l, LISP env)
  2001. {
  2002.   LISP result, v1, v2, tmp;
  2003.   if NULLP
  2004.     (l) return (NIL);
  2005.   if NCONSP
  2006.     (l) my_err ("bad syntax argument list", l);
  2007.   result = cons (leval (CAR (l), env), NIL);
  2008.   for (v1 = result, v2 = CDR (l);
  2009.        CONSP (v2);
  2010.        v1 = tmp, v2 = CDR (v2))
  2011.     {
  2012.       tmp = cons (leval (CAR (v2), env), NIL);
  2013.       CDR (v1) = tmp;
  2014.     }
  2015.   if NNULLP
  2016.     (v2) my_err ("bad syntax argument list", l);
  2017.   return (result);
  2018. }
  2019.  
  2020. LISP
  2021. extend_env (LISP actuals, LISP formals, LISP env)
  2022. {
  2023.   if SYMBOLP
  2024.     (formals)
  2025.       return (cons (cons (cons (formals, NIL), cons (actuals, NIL)), env));
  2026.   return (cons (cons (formals, actuals), env));
  2027. }
  2028.  
  2029. #define ENVLOOKUP_TRICK 1
  2030.  
  2031. LISP
  2032. envlookup (LISP var, LISP env)
  2033. {
  2034.   LISP frame, al, fl, tmp;
  2035.   for (frame = env; CONSP (frame); frame = CDR (frame))
  2036.     {
  2037.       tmp = CAR (frame);
  2038.       if NCONSP
  2039.     (tmp) my_err ("damaged frame", tmp);
  2040.       for (fl = CAR (tmp), al = CDR (tmp); CONSP (fl); fl = CDR (fl), al = CDR (al))
  2041.     {
  2042.       if NCONSP
  2043.         (al) my_err ("too few arguments", tmp);
  2044.       if EQ
  2045.         (CAR (fl), var) return (al);
  2046.     }
  2047.       /* suggested by a user. It works for reference (although conses)
  2048.          but doesn't allow for set! to work properly... */
  2049. #if (ENVLOOKUP_TRICK)
  2050.       if (SYMBOLP (fl) && EQ (fl, var))
  2051.     return (cons (al, NIL));
  2052. #endif
  2053.     }
  2054.   if NNULLP
  2055.     (frame) my_err ("damaged env", env);
  2056.   return (NIL);
  2057. }
  2058.  
  2059. void
  2060. set_eval_hooks (long type, LISP (*fcn) (LISP, LISP *, LISP *))
  2061. {
  2062.   struct user_type_hooks *p;
  2063.   p = get_user_type_hooks (type);
  2064.   p->leval = fcn;
  2065. }
  2066.  
  2067. LISP
  2068. err_closure_code (LISP tmp)
  2069. {
  2070.   return (my_err ("closure code type not valid", tmp));
  2071. }
  2072.  
  2073. LISP
  2074. leval (LISP x, LISP env)
  2075. {
  2076.   LISP tmp, arg1;
  2077.   struct user_type_hooks *p;
  2078.   STACK_CHECK (&x);
  2079. loop:
  2080.   INTERRUPT_CHECK ();
  2081.   tmp = VCELL (sym_eval_history_ptr);
  2082.   if TYPEP
  2083.     (tmp, tc_cons)
  2084.     {
  2085.       CAR (tmp) = x;
  2086.       VCELL (sym_eval_history_ptr) = CDR (tmp);
  2087.     }
  2088.   switch TYPE
  2089.     (x)
  2090.     {
  2091.     case tc_symbol:
  2092.       tmp = envlookup (x, env);
  2093.       if NNULLP
  2094.     (tmp) return (CAR (tmp));
  2095.       tmp = VCELL (x);
  2096.       if EQ
  2097.     (tmp, unbound_marker) err_ubv (x);
  2098.       return (tmp);
  2099.     case tc_cons:
  2100.       tmp = CAR (x);
  2101.       switch TYPE
  2102.     (tmp)
  2103.     {
  2104.     case tc_symbol:
  2105.       tmp = envlookup (tmp, env);
  2106.       if NNULLP
  2107.         (tmp)
  2108.         {
  2109.           tmp = CAR (tmp);
  2110.           break;
  2111.         }
  2112.       tmp = VCELL (CAR (x));
  2113.       if EQ
  2114.         (tmp, unbound_marker) err_ubv (CAR (x));
  2115.       break;
  2116.     case tc_cons:
  2117.       tmp = leval (tmp, env);
  2118.       break;
  2119.     }
  2120.       switch TYPE
  2121.     (tmp)
  2122.     {
  2123.     case tc_subr_0:
  2124.       return (SUBR0 (tmp) ());
  2125.     case tc_subr_1:
  2126.       return (SUBR1 (tmp) (leval (car (CDR (x)), env)));
  2127.     case tc_subr_2:
  2128.       x = CDR (x);
  2129.       arg1 = leval (car (x), env);
  2130.       x = NULLP (x) ? NIL : CDR (x);
  2131.       return (SUBR2 (tmp) (arg1,
  2132.                    leval (car (x), env)));
  2133.     case tc_subr_2n:
  2134.       x = CDR (x);
  2135.       arg1 = leval (car (x), env);
  2136.       x = NULLP (x) ? NIL : CDR (x);
  2137.       arg1 = SUBR2 (tmp) (arg1,
  2138.                   leval (car (x), env));
  2139.       for (x = cdr (x); CONSP (x); x = CDR (x))
  2140.         arg1 = SUBR2 (tmp) (arg1, leval (CAR (x), env));
  2141.       return (arg1);
  2142.     case tc_subr_3:
  2143.       x = CDR (x);
  2144.       arg1 = leval (car (x), env);
  2145.       x = NULLP (x) ? NIL : CDR (x);
  2146.       return (SUBR3 (tmp) (arg1,
  2147.                    leval (car (x), env),
  2148.                    leval (car (cdr (x)), env)));
  2149.  
  2150.     case tc_subr_4:
  2151.       x = CDR (x);
  2152.       arg1 = leval (car (x), env);
  2153.       x = NULLP (x) ? NIL : CDR (x);
  2154.       return (SUBR4 (tmp) (arg1,
  2155.                    leval (car (x), env),
  2156.                    leval (car (cdr (x)), env),
  2157.                    leval (car (cdr (cdr (x))), env)));
  2158.  
  2159.     case tc_subr_5:
  2160.       x = CDR (x);
  2161.       arg1 = leval (car (x), env);
  2162.       x = NULLP (x) ? NIL : CDR (x);
  2163.       return (SUBR5 (tmp) (arg1,
  2164.                    leval (car (x), env),
  2165.                    leval (car (cdr (x)), env),
  2166.                    leval (car (cdr (cdr (x))), env),
  2167.                    leval (car (cdr (cdr (cdr (x)))), env)));
  2168.  
  2169.     case tc_lsubr:
  2170.       return (SUBR1 (tmp) (leval_args (CDR (x), env)));
  2171.     case tc_fsubr:
  2172.       return (SUBR2 (tmp) (CDR (x), env));
  2173.     case tc_msubr:
  2174.       if NULLP
  2175.         (SUBRM (tmp) (&x, &env)) return (x);
  2176.       goto loop;
  2177.     case tc_closure:
  2178.       switch TYPE
  2179.         ((*tmp).storage_as.closure.code)
  2180.         {
  2181.         case tc_cons:
  2182.           env = extend_env (leval_args (CDR (x), env),
  2183.                 CAR ((*tmp).storage_as.closure.code),
  2184.                 (*tmp).storage_as.closure.env);
  2185.           x = CDR ((*tmp).storage_as.closure.code);
  2186.           goto loop;
  2187.         case tc_subr_1:
  2188.           return (SUBR1 (tmp->storage_as.closure.code)
  2189.               (tmp->storage_as.closure.env));
  2190.         case tc_subr_2:
  2191.           x = CDR (x);
  2192.           arg1 = leval (car (x), env);
  2193.           return (SUBR2 (tmp->storage_as.closure.code)
  2194.               (tmp->storage_as.closure.env, arg1));
  2195.         case tc_subr_3:
  2196.           x = CDR (x);
  2197.           arg1 = leval (car (x), env);
  2198.           x = NULLP (x) ? NIL : CDR (x);
  2199.           return (SUBR3 (tmp->storage_as.closure.code)
  2200.               (tmp->storage_as.closure.env,
  2201.                arg1,
  2202.                leval (car (x), env)));
  2203.         case tc_subr_4:
  2204.           x = CDR (x);
  2205.           arg1 = leval (car (x), env);
  2206.           x = NULLP (x) ? NIL : CDR (x);
  2207.           return (SUBR4 (tmp->storage_as.closure.code)
  2208.               (tmp->storage_as.closure.env,
  2209.                arg1,
  2210.                leval (car (x), env),
  2211.                leval (car (cdr (x)), env)));
  2212.         case tc_subr_5:
  2213.           x = CDR (x);
  2214.           arg1 = leval (car (x), env);
  2215.           x = NULLP (x) ? NIL : CDR (x);
  2216.           return (SUBR5 (tmp->storage_as.closure.code)
  2217.               (tmp->storage_as.closure.env,
  2218.                arg1,
  2219.                leval (car (x), env),
  2220.                leval (car (cdr (x)), env),
  2221.                leval (car (cdr (cdr (x))), env)));
  2222.  
  2223.         case tc_lsubr:
  2224.           return (SUBR1 (tmp->storage_as.closure.code)
  2225.               (cons (tmp->storage_as.closure.env,
  2226.                  leval_args (CDR (x), env))));
  2227.         default:
  2228.           err_closure_code (tmp);
  2229.         }
  2230.       break;
  2231.     case tc_symbol:
  2232.       x = cons (tmp, cons (cons (sym_quote, cons (x, NIL)), NIL));
  2233.       x = leval (x, NIL);
  2234.       goto loop;
  2235.     default:
  2236.       p = get_user_type_hooks (TYPE (tmp));
  2237.       if (p->leval)
  2238.         {
  2239.           if NULLP
  2240.         ((*p->leval) (tmp, &x, &env)) return (x);
  2241.           else
  2242.         goto loop;
  2243.         }
  2244.       my_err ("bad function", tmp);
  2245.     }
  2246.     default:
  2247.       return (x);
  2248.     }
  2249. }
  2250.  
  2251. LISP
  2252. lapply (LISP fcn, LISP args)
  2253. {
  2254.   struct user_type_hooks *p;
  2255.   LISP acc;
  2256.   STACK_CHECK (&fcn);
  2257.   INTERRUPT_CHECK ();
  2258.   switch TYPE
  2259.     (fcn)
  2260.     {
  2261.     case tc_subr_0:
  2262.       return (SUBR0 (fcn) ());
  2263.     case tc_subr_1:
  2264.       return (SUBR1 (fcn) (car (args)));
  2265.     case tc_subr_2:
  2266.       return (SUBR2 (fcn) (car (args), car (cdr (args))));
  2267.     case tc_subr_2n:
  2268.       acc = SUBR2 (fcn) (car (args), car (cdr (args)));
  2269.       for (args = cdr (cdr (args)); CONSP (args); args = CDR (args))
  2270.     acc = SUBR2 (fcn) (acc, CAR (args));
  2271.       return (acc);
  2272.     case tc_subr_3:
  2273.       return (SUBR3 (fcn) (car (args), car (cdr (args)), car (cdr (cdr (args)))));
  2274.     case tc_subr_4:
  2275.       return (SUBR4 (fcn) (car (args), car (cdr (args)), car (cdr (cdr (args))),
  2276.                car (cdr (cdr (cdr (args))))));
  2277.     case tc_subr_5:
  2278.       return (SUBR5 (fcn) (car (args), car (cdr (args)), car (cdr (cdr (args))),
  2279.                car (cdr (cdr (cdr (args)))),
  2280.                car (cdr (cdr (cdr (cdr (args)))))));
  2281.     case tc_lsubr:
  2282.       return (SUBR1 (fcn) (args));
  2283.     case tc_fsubr:
  2284.     case tc_msubr:
  2285.     case tc_symbol:
  2286.       my_err ("cannot be applied", fcn);
  2287.     case tc_closure:
  2288.       switch TYPE
  2289.     (fcn->storage_as.closure.code)
  2290.     {
  2291.     case tc_cons:
  2292.       return (leval (cdr (fcn->storage_as.closure.code),
  2293.              extend_env (args,
  2294.                      car (fcn->storage_as.closure.code),
  2295.                      fcn->storage_as.closure.env)));
  2296.     case tc_subr_1:
  2297.       return (SUBR1 (fcn->storage_as.closure.code)
  2298.           (fcn->storage_as.closure.env));
  2299.     case tc_subr_2:
  2300.       return (SUBR2 (fcn->storage_as.closure.code)
  2301.           (fcn->storage_as.closure.env,
  2302.            car (args)));
  2303.     case tc_subr_3:
  2304.       return (SUBR3 (fcn->storage_as.closure.code)
  2305.           (fcn->storage_as.closure.env,
  2306.            car (args), car (cdr (args))));
  2307.     case tc_subr_4:
  2308.       return (SUBR4 (fcn->storage_as.closure.code)
  2309.           (fcn->storage_as.closure.env,
  2310.            car (args), car (cdr (args)), car (cdr (cdr (args)))));
  2311.     case tc_subr_5:
  2312.       return (SUBR5 (fcn->storage_as.closure.code)
  2313.           (fcn->storage_as.closure.env,
  2314.            car (args), car (cdr (args)), car (cdr (cdr (args))),
  2315.            car (cdr (cdr (cdr (args))))));
  2316.     case tc_lsubr:
  2317.       return (SUBR1 (fcn->storage_as.closure.code)
  2318.           (cons (fcn->storage_as.closure.env, args)));
  2319.     default:
  2320.       err_closure_code (fcn);
  2321.     }
  2322.     default:
  2323.       p = get_user_type_hooks (TYPE (fcn));
  2324.       if (p->leval)
  2325.     return my_err ("have eval, dont know apply", fcn);
  2326.       else
  2327.     return my_err ("cannot be applied", fcn);
  2328.     }
  2329. }
  2330.  
  2331. LISP
  2332. setvar (LISP var, LISP val, LISP env)
  2333. {
  2334.   LISP tmp;
  2335.   if NSYMBOLP
  2336.     (var) my_err ("wta(non-symbol) to setvar", var);
  2337.   tmp = envlookup (var, env);
  2338.   if NULLP
  2339.     (tmp) return (VCELL (var) = val);
  2340.   return (CAR (tmp) = val);
  2341. }
  2342.  
  2343. LISP
  2344. leval_setq (LISP args, LISP env)
  2345. {
  2346.   return (setvar (car (args), leval (car (cdr (args)), env), env));
  2347. }
  2348.  
  2349. LISP
  2350. syntax_define (LISP args)
  2351. {
  2352.   if SYMBOLP
  2353.     (car (args)) return (args);
  2354.   return (syntax_define (
  2355.               cons (car (car (args)),
  2356.                 cons (cons (sym_lambda,
  2357.                         cons (cdr (car (args)),
  2358.                           cdr (args))),
  2359.                       NIL))));
  2360. }
  2361.  
  2362. LISP
  2363. leval_define (LISP args, LISP env)
  2364. {
  2365.   LISP tmp, var, val;
  2366.   tmp = syntax_define (args);
  2367.   var = car (tmp);
  2368.   if NSYMBOLP
  2369.     (var) my_err ("wta(non-symbol) to define", var);
  2370.   val = leval (car (cdr (tmp)), env);
  2371.   tmp = envlookup (var, env);
  2372.   if NNULLP
  2373.     (tmp) return (CAR (tmp) = val);
  2374.   if NULLP
  2375.     (env) return (VCELL (var) = val);
  2376.   tmp = car (env);
  2377.   setcar (tmp, cons (var, car (tmp)));
  2378.   setcdr (tmp, cons (val, cdr (tmp)));
  2379.   return (val);
  2380. }
  2381.  
  2382. LISP
  2383. leval_if (LISP * pform, LISP * penv)
  2384. {
  2385.   LISP args, env;
  2386.   args = cdr (*pform);
  2387.   env = *penv;
  2388.   if NNULLP
  2389.     (leval (car (args), env))
  2390.       * pform = car (cdr (args));
  2391.   else
  2392.     *pform = car (cdr (cdr (args)));
  2393.   return (sym_t);
  2394. }
  2395.  
  2396. LISP
  2397. leval_lambda (LISP args, LISP env)
  2398. {
  2399.   LISP body;
  2400.   if NULLP
  2401.     (cdr (cdr (args)))
  2402.       body = car (cdr (args));
  2403.   else
  2404.     body = cons (sym_progn, cdr (args));
  2405.   return (closure (env, cons (arglchk (car (args)), body)));
  2406. }
  2407.  
  2408. LISP
  2409. leval_progn (LISP * pform, LISP * penv)
  2410. {
  2411.   LISP env, l, next;
  2412.   env = *penv;
  2413.   l = cdr (*pform);
  2414.   next = cdr (l);
  2415.   while (NNULLP (next))
  2416.     {
  2417.       leval (car (l), env);
  2418.       l = next;
  2419.       next = cdr (next);
  2420.     }
  2421.   *pform = car (l);
  2422.   return (sym_t);
  2423. }
  2424.  
  2425. LISP
  2426. leval_or (LISP * pform, LISP * penv)
  2427. {
  2428.   LISP env, l, next, val;
  2429.   env = *penv;
  2430.   l = cdr (*pform);
  2431.   next = cdr (l);
  2432.   while (NNULLP (next))
  2433.     {
  2434.       val = leval (car (l), env);
  2435.       if NNULLP
  2436.     (val)
  2437.     {
  2438.       *pform = val;
  2439.       return (NIL);
  2440.     }
  2441.       l = next;
  2442.       next = cdr (next);
  2443.     }
  2444.   *pform = car (l);
  2445.   return (sym_t);
  2446. }
  2447.  
  2448. LISP
  2449. leval_and (LISP * pform, LISP * penv)
  2450. {
  2451.   LISP env, l, next;
  2452.   env = *penv;
  2453.   l = cdr (*pform);
  2454.   if NULLP
  2455.     (l)
  2456.     {
  2457.       *pform = sym_t;
  2458.       return (NIL);
  2459.     }
  2460.   next = cdr (l);
  2461.   while (NNULLP (next))
  2462.     {
  2463.       if NULLP
  2464.     (leval (car (l), env))
  2465.     {
  2466.       *pform = NIL;
  2467.       return (NIL);
  2468.     }
  2469.       l = next;
  2470.       next = cdr (next);
  2471.     }
  2472.   *pform = car (l);
  2473.   return (sym_t);
  2474. }
  2475.  
  2476. LISP
  2477. leval_catch_1 (LISP forms, LISP env)
  2478. {
  2479.   LISP l, val = NIL;
  2480.   for (l = forms; NNULLP (l); l = cdr (l))
  2481.     val = leval (car (l), env);
  2482.   catch_framep = catch_framep->next;
  2483.   return (val);
  2484. }
  2485.  
  2486. LISP
  2487. leval_catch (LISP args, LISP env)
  2488. {
  2489.   struct catch_frame frame;
  2490.   int k;
  2491.   frame.tag = leval (car (args), env);
  2492.   frame.next = catch_framep;
  2493.   k = setjmp (frame.cframe);
  2494.   catch_framep = &frame;
  2495.   if (k == 2)
  2496.     {
  2497.       catch_framep = frame.next;
  2498.       return (frame.retval);
  2499.     }
  2500.   return (leval_catch_1 (cdr (args), env));
  2501. }
  2502.  
  2503. LISP
  2504. lthrow (LISP tag, LISP value)
  2505. {
  2506.   struct catch_frame *l;
  2507.   for (l = catch_framep; l; l = (*l).next)
  2508.     if (EQ ((*l).tag, tag) ||
  2509.     EQ ((*l).tag, sym_catchall))
  2510.       {
  2511.     (*l).retval = value;
  2512.     longjmp ((*l).cframe, 2);
  2513.       }
  2514.   my_err ("no *catch found with this tag", tag);
  2515.   return (NIL);
  2516. }
  2517.  
  2518. LISP
  2519. leval_let (LISP * pform, LISP * penv)
  2520. {
  2521.   LISP env, l;
  2522.   l = cdr (*pform);
  2523.   env = *penv;
  2524.   *penv = extend_env (leval_args (car (cdr (l)), env), car (l), env);
  2525.   *pform = car (cdr (cdr (l)));
  2526.   return (sym_t);
  2527. }
  2528.  
  2529. LISP
  2530. letstar_macro (LISP form)
  2531. {
  2532.   LISP bindings = cadr (form);
  2533.   if (NNULLP (bindings) && NNULLP (cdr (bindings)))
  2534.     setcdr (form, cons (cons (car (bindings), NIL),
  2535.             cons (cons (cintern ("let*"),
  2536.                     cons (cdr (bindings),
  2537.                       cddr (form))),
  2538.                   NIL)));
  2539.   setcar (form, cintern ("let"));
  2540.   return (form);
  2541. }
  2542.  
  2543. LISP
  2544. letrec_macro (LISP form)
  2545. {
  2546.   LISP letb, setb, l;
  2547.   for (letb = NIL, setb = cddr (form), l = cadr (form); NNULLP (l); l = cdr (l))
  2548.     {
  2549.       letb = cons (cons (caar (l), NIL), letb);
  2550.       setb = cons (listn (3, cintern ("set!"), caar (l), cadar (l)), setb);
  2551.     }
  2552.   setcdr (form, cons (letb, setb));
  2553.   setcar (form, cintern ("let"));
  2554.   return (form);
  2555. }
  2556.  
  2557. LISP
  2558. reverse (LISP l)
  2559. {
  2560.   LISP n, p;
  2561.   n = NIL;
  2562.   for (p = l; NNULLP (p); p = cdr (p))
  2563.     n = cons (car (p), n);
  2564.   return (n);
  2565. }
  2566.  
  2567. LISP
  2568. let_macro (LISP form)
  2569. {
  2570.   LISP p, fl, al, tmp;
  2571.   fl = NIL;
  2572.   al = NIL;
  2573.   for (p = car (cdr (form)); NNULLP (p); p = cdr (p))
  2574.     {
  2575.       tmp = car (p);
  2576.       if SYMBOLP
  2577.     (tmp)
  2578.     {
  2579.       fl = cons (tmp, fl);
  2580.       al = cons (NIL, al);
  2581.     }
  2582.       else
  2583.     {
  2584.       fl = cons (car (tmp), fl);
  2585.       al = cons (car (cdr (tmp)), al);
  2586.     }
  2587.     }
  2588.   p = cdr (cdr (form));
  2589.   if NULLP
  2590.     (cdr (p)) p = car (p);
  2591.   else
  2592.     p = cons (sym_progn, p);
  2593.   setcdr (form, cons (reverse (fl), cons (reverse (al), cons (p, NIL))));
  2594.   setcar (form, cintern ("let-internal"));
  2595.   return (form);
  2596. }
  2597.  
  2598. LISP
  2599. leval_quote (LISP args, LISP env)
  2600. {
  2601.   return (car (args));
  2602. }
  2603.  
  2604. LISP
  2605. leval_tenv (LISP args, LISP env)
  2606. {
  2607.   return (env);
  2608. }
  2609.  
  2610. LISP
  2611. leval_while (LISP args, LISP env)
  2612. {
  2613.   LISP l;
  2614.   while NNULLP
  2615.     (leval (car (args), env))
  2616.       for (l = cdr (args); NNULLP (l); l = cdr (l))
  2617.       leval (car (l), env);
  2618.   return (NIL);
  2619. }
  2620.  
  2621. LISP
  2622. symbolconc (LISP args)
  2623. {
  2624.   long size;
  2625.   LISP l, s;
  2626.   size = 0;
  2627.   tkbuffer[0] = 0;
  2628.   for (l = args; NNULLP (l); l = cdr (l))
  2629.     {
  2630.       s = car (l);
  2631.       if NSYMBOLP
  2632.     (s) my_err ("wta(non-symbol) to symbolconc", s);
  2633.       size = size + strlen (PNAME (s));
  2634.       if (size > TKBUFFERN)
  2635.     my_err ("symbolconc buffer overflow", NIL);
  2636.       strcat (tkbuffer, PNAME (s));
  2637.     }
  2638.   return (rintern (tkbuffer));
  2639. }
  2640.  
  2641. void
  2642. set_print_hooks (long type, void (*fcn) (LISP, struct gen_printio *))
  2643. {
  2644.   struct user_type_hooks *p;
  2645.   p = get_user_type_hooks (type);
  2646.   p->prin1 = fcn;
  2647. }
  2648.  
  2649. char *
  2650. subr_kind_str (long n)
  2651. {
  2652.   switch (n)
  2653.     {
  2654.     case tc_subr_0:
  2655.       return ("subr_0");
  2656.     case tc_subr_1:
  2657.       return ("subr_1");
  2658.     case tc_subr_2:
  2659.       return ("subr_2");
  2660.     case tc_subr_2n:
  2661.       return ("subr_2n");
  2662.     case tc_subr_3:
  2663.       return ("subr_3");
  2664.     case tc_subr_4:
  2665.       return ("subr_4");
  2666.     case tc_subr_5:
  2667.       return ("subr_5");
  2668.     case tc_lsubr:
  2669.       return ("lsubr");
  2670.     case tc_fsubr:
  2671.       return ("fsubr");
  2672.     case tc_msubr:
  2673.       return ("msubr");
  2674.     default:
  2675.       return ("???");
  2676.     }
  2677. }
  2678.  
  2679. LISP
  2680. lprin1g (LISP exp, struct gen_printio * f)
  2681. {
  2682.   LISP tmp;
  2683.   long n;
  2684.   struct user_type_hooks *p;
  2685.   STACK_CHECK (&exp);
  2686.   INTERRUPT_CHECK ();
  2687.   switch TYPE
  2688.     (exp)
  2689.     {
  2690.     case tc_nil:
  2691.       gput_st (f, "()");
  2692.       break;
  2693.     case tc_cons:
  2694.       gput_st (f, "(");
  2695.       lprin1g (car (exp), f);
  2696.       for (tmp = cdr (exp); CONSP (tmp); tmp = cdr (tmp))
  2697.     {
  2698.       gput_st (f, " ");
  2699.       lprin1g (car (tmp), f);
  2700.     }
  2701.       if NNULLP
  2702.     (tmp)
  2703.     {
  2704.       gput_st (f, " . ");
  2705.       lprin1g (tmp, f);
  2706.     }
  2707.       gput_st (f, ")");
  2708.       break;
  2709.     case tc_flonum:
  2710.       n = (long) FLONM (exp);
  2711.       if (((double) n) == FLONM (exp))
  2712.     sprintf (tkbuffer, "%ld", n);
  2713.       else
  2714.     sprintf (tkbuffer, "%g", FLONM (exp));
  2715.       gput_st (f, tkbuffer);
  2716.       break;
  2717.     case tc_symbol:
  2718.       gput_st (f, PNAME (exp));
  2719.       break;
  2720.     case tc_subr_0:
  2721.     case tc_subr_1:
  2722.     case tc_subr_2:
  2723.     case tc_subr_2n:
  2724.     case tc_subr_3:
  2725.     case tc_subr_4:
  2726.     case tc_subr_5:
  2727.     case tc_lsubr:
  2728.     case tc_fsubr:
  2729.     case tc_msubr:
  2730.       sprintf (tkbuffer, "#<%s ", subr_kind_str (TYPE (exp)));
  2731.       gput_st (f, tkbuffer);
  2732.       gput_st (f, (*exp).storage_as.subr.name);
  2733.       gput_st (f, ">");
  2734.       break;
  2735.     case tc_closure:
  2736.       gput_st (f, "#<CLOSURE ");
  2737.       if CONSP
  2738.     ((*exp).storage_as.closure.code)
  2739.     {
  2740.       lprin1g (car ((*exp).storage_as.closure.code), f);
  2741.       gput_st (f, " ");
  2742.       lprin1g (cdr ((*exp).storage_as.closure.code), f);
  2743.     }
  2744.       else
  2745.     lprin1g ((*exp).storage_as.closure.code, f);
  2746.       gput_st (f, ">");
  2747.       break;
  2748.     default:
  2749.       p = get_user_type_hooks (TYPE (exp));
  2750.       if (p->prin1)
  2751.     (*p->prin1) (exp, f);
  2752.       else
  2753.     {
  2754.       sprintf (tkbuffer, "#<UNKNOWN %d %p>", TYPE (exp), exp);
  2755.       gput_st (f, tkbuffer);
  2756.     }
  2757.     }
  2758.   return (NIL);
  2759. }
  2760.  
  2761. LISP
  2762. lprint (LISP exp, LISP lf)
  2763. {
  2764.   FILE *f = get_c_file (lf, siod_output);
  2765.   lprin1f (exp, f);
  2766.   if (siod_verbose_level > 0)
  2767.     fput_st (f, "\n");
  2768.   return (NIL);
  2769. }
  2770.  
  2771. LISP
  2772. lprin1 (LISP exp, LISP lf)
  2773. {
  2774.   FILE *f = get_c_file (lf, siod_output);
  2775.   lprin1f (exp, f);
  2776.   return (NIL);
  2777. }
  2778.  
  2779. LISP
  2780. lprin1f (LISP exp, FILE * f)
  2781. {
  2782.   struct gen_printio s;
  2783.   s.putc_fcn = NULL;
  2784.   s.puts_fcn = fputs_fcn;
  2785.   s.cb_argument = f;
  2786.   lprin1g (exp, &s);
  2787.   return (NIL);
  2788. }
  2789.  
  2790. LISP
  2791. lread (LISP f)
  2792. {
  2793.   return (lreadf (get_c_file (f, stdin)));
  2794. }
  2795.  
  2796. int
  2797. f_getc (FILE * f)
  2798. {
  2799.   long iflag, dflag;
  2800.   int c;
  2801.   iflag = no_interrupt (1);
  2802.   dflag = interrupt_differed;
  2803.   c = getc (f);
  2804. #ifdef VMS
  2805.   if ((dflag == 0) & interrupt_differed & (f == stdin))
  2806.     while ((c != 0) & (c != EOF))
  2807.       c = getc (f);
  2808. #endif
  2809.   no_interrupt (iflag);
  2810.   return (c);
  2811. }
  2812.  
  2813. void
  2814. f_ungetc (int c, FILE * f)
  2815. {
  2816.   ungetc (c, f);
  2817. }
  2818.  
  2819. int
  2820. flush_ws (struct gen_readio *f, char *eoferr)
  2821. {
  2822.   int c, commentp;
  2823.   commentp = 0;
  2824.   while (1)
  2825.     {
  2826.       c = GETC_FCN (f);
  2827.       if (c == EOF)
  2828.     {
  2829.       if (eoferr)
  2830.         my_err (eoferr, NIL);
  2831.       else
  2832.         return (c);
  2833.     }
  2834.       
  2835.       if (commentp)
  2836.     {
  2837.       if (c == '\n')
  2838.         commentp = 0;
  2839.     }
  2840.       else if (c == ';')
  2841.     commentp = 1;
  2842.       else if (!isspace (c))
  2843.     return (c);
  2844.     }
  2845. }
  2846.  
  2847. LISP
  2848. lreadf (FILE * f)
  2849. {
  2850.   struct gen_readio s;
  2851.   s.getc_fcn = (int (*)(void *)) f_getc;
  2852.   s.ungetc_fcn = (void (*)(int, void *)) f_ungetc;
  2853.   s.cb_argument = (char *) f;
  2854.   return (readtl (&s));
  2855. }
  2856.  
  2857. LISP
  2858. readtl (struct gen_readio * f)
  2859. {
  2860.   int c;
  2861.   c = flush_ws (f, (char *) NULL);
  2862.   if (c == EOF)
  2863.     return (eof_val);
  2864.   UNGETC_FCN (c, f);
  2865.   return (lreadr (f));
  2866. }
  2867.  
  2868. void
  2869. set_read_hooks (char *all_set, char *end_set,
  2870.         LISP (*fcn1) (int, struct gen_readio *),
  2871.         LISP (*fcn2) (char *, long, int *))
  2872. {
  2873.   user_ch_readm = all_set;
  2874.   user_te_readm = end_set;
  2875.   user_readm = fcn1;
  2876.   user_readt = fcn2;
  2877. }
  2878.  
  2879. LISP
  2880. lreadr (struct gen_readio *f)
  2881. {
  2882.   int c, j;
  2883.   char *p, *buffer = tkbuffer;
  2884.   STACK_CHECK (&f);
  2885.   p = buffer;
  2886.   c = flush_ws (f, "end of file inside read");
  2887.   switch (c)
  2888.     {
  2889.     case '(':
  2890.       return (lreadparen (f));
  2891.     case ')':
  2892.       my_err ("unexpected close paren", NIL);
  2893.     case '\'':
  2894.       return (cons (sym_quote, cons (lreadr (f), NIL)));
  2895.     case '`':
  2896.       return (cons (cintern ("+internal-backquote"), lreadr (f)));
  2897.     case ',':
  2898.       c = GETC_FCN (f);
  2899.       switch (c)
  2900.     {
  2901.     case '@':
  2902.       p = "+internal-comma-atsign";
  2903.       break;
  2904.     case '.':
  2905.       p = "+internal-comma-dot";
  2906.       break;
  2907.     default:
  2908.       p = "+internal-comma";
  2909.       UNGETC_FCN (c, f);
  2910.     }
  2911.       return (cons (cintern (p), lreadr (f)));
  2912.     case '_':  /*  might be a string marked for translation using _(...)  */
  2913.       c = GETC_FCN (f);
  2914.       if (c == '"')
  2915.     return (lreadstring (f));
  2916.       else
  2917.     UNGETC_FCN (c, f);
  2918.       break;
  2919.     case '"':
  2920.       return (lreadstring (f));
  2921.     case '#':
  2922.       return (lreadsharp (f));
  2923.     default:
  2924.       if ((user_readm != NULL) && strchr (user_ch_readm, c))
  2925.     return ((*user_readm) (c, f));
  2926.     }
  2927.   *p++ = c;
  2928.   for (j = 1; j < TKBUFFERN; ++j)
  2929.     {
  2930.       c = GETC_FCN (f);
  2931.       if (c == EOF)
  2932.     return (lreadtk (buffer, j));
  2933.       if (isspace (c))
  2934.     return (lreadtk (buffer, j));
  2935.       if (strchr ("()'`,;\"", c) || strchr (user_te_readm, c))
  2936.     {
  2937.       UNGETC_FCN (c, f);
  2938.       return (lreadtk (buffer, j));
  2939.     }
  2940.       *p++ = c;
  2941.     }
  2942.   return (my_err ("token larger than TKBUFFERN", NIL));
  2943. }
  2944.  
  2945. LISP
  2946. lreadparen (struct gen_readio * f)
  2947. {
  2948.   int c;
  2949.   LISP tmp;
  2950.   c = flush_ws (f, "end of file inside list");
  2951.   if (c == ')')
  2952.     return (NIL);
  2953.   UNGETC_FCN (c, f);
  2954.   tmp = lreadr (f);
  2955.   if EQ
  2956.     (tmp, sym_dot)
  2957.     {
  2958.       tmp = lreadr (f);
  2959.       c = flush_ws (f, "end of file inside list");
  2960.       if (c != ')')
  2961.     my_err ("missing close paren", NIL);
  2962.       return (tmp);
  2963.     }
  2964.   return (cons (tmp, lreadparen (f)));
  2965. }
  2966.  
  2967. LISP
  2968. lreadtk (char *buffer, long j)
  2969. {
  2970.   int flag;
  2971.   LISP tmp;
  2972.   int adigit;
  2973.   char *p = buffer;
  2974.   p[j] = 0;
  2975.   if (user_readt != NULL)
  2976.     {
  2977.       tmp = (*user_readt) (p, j, &flag);
  2978.       if (flag)
  2979.     return (tmp);
  2980.     }
  2981.   if (*p == '-')
  2982.     p += 1;
  2983.   adigit = 0;
  2984.   while (isdigit (*p))
  2985.     {
  2986.       p += 1;
  2987.       adigit = 1;
  2988.     }
  2989.   if (*p == '.')
  2990.     {
  2991.       p += 1;
  2992.       while (isdigit (*p))
  2993.     {
  2994.       p += 1;
  2995.       adigit = 1;
  2996.     }
  2997.     }
  2998.   if (!adigit)
  2999.     goto a_symbol;
  3000.   if (*p == 'e')
  3001.     {
  3002.       p += 1;
  3003.       if (*p == '-' || *p == '+')
  3004.     p += 1;
  3005.       if (!isdigit (*p))
  3006.     goto a_symbol;
  3007.       else
  3008.     p += 1;
  3009.       while (isdigit (*p))
  3010.     p += 1;
  3011.     }
  3012.   if (*p)
  3013.     goto a_symbol;
  3014.   return (flocons (atof (buffer)));
  3015. a_symbol:
  3016.   return (rintern (buffer));
  3017. }
  3018.  
  3019. LISP
  3020. copy_list (LISP x)
  3021. {
  3022.   if NULLP
  3023.     (x) return (NIL);
  3024.   STACK_CHECK (&x);
  3025.   return (cons (car (x), copy_list (cdr (x))));
  3026. }
  3027.  
  3028. LISP
  3029. apropos (LISP matchl)
  3030. {
  3031.   LISP result = NIL, l, ml;
  3032.   char *pname;
  3033.   for (l = oblistvar; CONSP (l); l = CDR (l))
  3034.     {
  3035.       pname = get_c_string (CAR (l));
  3036.       ml = matchl;
  3037.       while (CONSP (ml) && strstr (pname, get_c_string (CAR (ml))))
  3038.     ml = CDR (ml);
  3039.       if NULLP
  3040.     (ml)
  3041.       result = cons (CAR (l), result);
  3042.     }
  3043.   return (result);
  3044. }
  3045.  
  3046. LISP
  3047. fopen_cg (FILE * (*fcn) (const char *, const char *), char *name, char *how)
  3048. {
  3049.   LISP sym;
  3050.   long flag;
  3051.   char errmsg[80];
  3052.   flag = no_interrupt (1);
  3053.   sym = newcell (tc_c_file);
  3054.   sym->storage_as.c_file.f = (FILE *) NULL;
  3055.   sym->storage_as.c_file.name = (char *) NULL;
  3056.   if (!(sym->storage_as.c_file.f = (*fcn) (name, how)))
  3057.     {
  3058.       SAFE_STRCPY (errmsg, "could not open ");
  3059.       SAFE_STRCAT (errmsg, name);
  3060.       my_err (errmsg, llast_c_errmsg (-1));
  3061.     }
  3062.   sym->storage_as.c_file.name = (char *) must_malloc (strlen (name) + 1);
  3063.   strcpy (sym->storage_as.c_file.name, name);
  3064.   no_interrupt (flag);
  3065.   return (sym);
  3066. }
  3067.  
  3068. LISP
  3069. fopen_c (char *name, char *how)
  3070. {
  3071.   return (fopen_cg (fopen, name, how));
  3072. }
  3073.  
  3074. LISP
  3075. fopen_l (LISP name, LISP how)
  3076. {
  3077.   return (fopen_c (get_c_string (name), NULLP (how) ? "r" : get_c_string (how)));
  3078. }
  3079.  
  3080. LISP
  3081. delq (LISP elem, LISP l)
  3082. {
  3083.   if NULLP
  3084.     (l) return (l);
  3085.   STACK_CHECK (&elem);
  3086.   if EQ
  3087.     (elem, car (l)) return (delq (elem, cdr (l)));
  3088.   setcdr (l, delq (elem, cdr (l)));
  3089.   return (l);
  3090. }
  3091.  
  3092. LISP
  3093. fclose_l (LISP p)
  3094. {
  3095.   long flag;
  3096.   flag = no_interrupt (1);
  3097.   if NTYPEP
  3098.     (p, tc_c_file) my_err ("not a file", p);
  3099.   file_gc_free (p);
  3100.   no_interrupt (flag);
  3101.   return (NIL);
  3102. }
  3103.  
  3104. LISP
  3105. vload (char *fname, long cflag, long rflag)
  3106. {
  3107.   LISP form, result, tail, lf, reader = NIL;
  3108.   FILE *f;
  3109.   int c, j;
  3110.   char buffer[512], *key = "parser:", *start, *end, *ftype = ".scm";
  3111.   if (rflag)
  3112.     {
  3113.       int iflag;
  3114.       iflag = no_interrupt (1);
  3115.       if ((f = fopen (fname, "r")))
  3116.     fclose (f);
  3117.       else if ((fname[0] != '/') &&
  3118.            ((strlen (siod_lib) + strlen (fname) + 1)
  3119.         < sizeof (buffer)))
  3120.     {
  3121.       strcpy (buffer, siod_lib);
  3122.       strcat (buffer, "/");
  3123.       strcat (buffer, fname);
  3124.       if ((f = fopen (buffer, "r")))
  3125.         {
  3126.           fname = buffer;
  3127.           fclose (f);
  3128.         }
  3129.     }
  3130.       no_interrupt (iflag);
  3131.     }
  3132.   if (siod_verbose_level >= 3)
  3133.     {
  3134.       put_st ("loading ");
  3135.       put_st (fname);
  3136.       put_st ("\n");
  3137.     }
  3138.   lf = fopen_c (fname, "r");
  3139.   f = lf->storage_as.c_file.f;
  3140.   result = NIL;
  3141.   tail = NIL;
  3142.   j = 0;
  3143.   buffer[0] = 0;
  3144.   c = getc (f);
  3145.   while ((c == '#') || (c == ';'))
  3146.     {
  3147.       while (((c = getc (f)) != EOF) && (c != '\n'))
  3148.     if ((j + 1) < sizeof (buffer))
  3149.       {
  3150.         buffer[j] = c;
  3151.         buffer[++j] = 0;
  3152.       }
  3153.       if (c == '\n')
  3154.     c = getc (f);
  3155.     }
  3156.   if (c != EOF)
  3157.     ungetc (c, f);
  3158.   if ((start = strstr (buffer, key)))
  3159.     {
  3160.       for (end = &start[strlen (key)];
  3161.        *end && isalnum (*end);
  3162.        ++end);
  3163.       j = end - start;
  3164.       g_memmove (buffer, start, j);
  3165.       buffer[strlen (key) - 1] = '_';
  3166.       buffer[j] = 0;
  3167.       strcat (buffer, ftype);
  3168.       require (strcons (-1, buffer));
  3169.       buffer[j] = 0;
  3170.       reader = rintern (buffer);
  3171.       reader = funcall1 (leval (reader, NIL), reader);
  3172.       if (siod_verbose_level >= 5)
  3173.     {
  3174.       put_st ("parser:");
  3175.       lprin1 (reader, NIL);
  3176.       put_st ("\n");
  3177.     }
  3178.     }
  3179.   while (1)
  3180.     {
  3181.       form = NULLP (reader) ? lread (lf) : funcall1 (reader, lf);
  3182.       if EQ
  3183.     (form, eof_val) break;
  3184.       if (siod_verbose_level >= 5)
  3185.     lprint (form, NIL);
  3186.       if (cflag)
  3187.     {
  3188.       form = cons (form, NIL);
  3189.       if NULLP
  3190.         (result)
  3191.           result = tail = form;
  3192.       else
  3193.         tail = setcdr (tail, form);
  3194.     }
  3195.       else
  3196.     leval (form, NIL);
  3197.     }
  3198.   fclose_l (lf);
  3199.   if (siod_verbose_level >= 3)
  3200.     put_st ("done.\n");
  3201.   return (result);
  3202. }
  3203.  
  3204. LISP
  3205. load (LISP fname, LISP cflag, LISP rflag)
  3206. {
  3207.   return (vload (get_c_string (fname), NULLP (cflag) ? 0 : 1, NULLP (rflag) ? 0 : 1));
  3208. }
  3209.  
  3210. LISP
  3211. require (LISP fname)
  3212. {
  3213.   LISP sym;
  3214.   sym = intern (string_append (cons (cintern ("*"),
  3215.                      cons (fname,
  3216.                        cons (cintern ("-loaded*"), NIL)))));
  3217.   if (NULLP (symbol_boundp (sym, NIL)) ||
  3218.       NULLP (symbol_value (sym, NIL)))
  3219.     {
  3220.       load (fname, NIL, sym_t);
  3221.       setvar (sym, sym_t, NIL);
  3222.     }
  3223.   return (sym);
  3224. }
  3225.  
  3226. LISP
  3227. save_forms (LISP fname, LISP forms, LISP how)
  3228. {
  3229.   char *cname, *chow = NULL;
  3230.   LISP l, lf;
  3231.   FILE *f;
  3232.   cname = get_c_string (fname);
  3233.   if EQ
  3234.     (how, NIL) chow = "w";
  3235.   else if EQ
  3236.     (how, cintern ("a")) chow = "a";
  3237.   else
  3238.     my_err ("bad argument to save-forms", how);
  3239.   if (siod_verbose_level >= 3)
  3240.     {
  3241.       put_st ((*chow == 'a') ? "appending" : "saving");
  3242.       put_st (" forms to ");
  3243.       put_st (cname);
  3244.       put_st ("\n");
  3245.     }
  3246.   lf = fopen_c (cname, chow);
  3247.   f = lf->storage_as.c_file.f;
  3248.   for (l = forms; NNULLP (l); l = cdr (l))
  3249.     {
  3250.       lprin1f (car (l), f);
  3251.       putc ('\n', f);
  3252.     }
  3253.   fclose_l (lf);
  3254.   if (siod_verbose_level >= 3)
  3255.     put_st ("done.\n");
  3256.   return (sym_t);
  3257. }
  3258.  
  3259. LISP
  3260. quit (void)
  3261. {
  3262.   return (my_err (NULL, NIL));
  3263. }
  3264.  
  3265. LISP
  3266. nullp (LISP x)
  3267. {
  3268.   if EQ
  3269.     (x, NIL) return (sym_t);
  3270.   else
  3271.     return (NIL);
  3272. }
  3273.  
  3274. LISP
  3275. arglchk (LISP x)
  3276. {
  3277. #if (!ENVLOOKUP_TRICK)
  3278.   LISP l;
  3279.   if SYMBOLP
  3280.     (x) return (x);
  3281.   for (l = x; CONSP (l); l = CDR (l));
  3282.   if NNULLP
  3283.     (l) my_err ("improper formal argument list", x);
  3284. #endif
  3285.   return (x);
  3286. }
  3287.  
  3288. void
  3289. file_gc_free (LISP ptr)
  3290. {
  3291.   if (ptr->storage_as.c_file.f)
  3292.     {
  3293.       fclose (ptr->storage_as.c_file.f);
  3294.       ptr->storage_as.c_file.f = (FILE *) NULL;
  3295.     }
  3296.   if (ptr->storage_as.c_file.name)
  3297.     {
  3298.       free (ptr->storage_as.c_file.name);
  3299.       ptr->storage_as.c_file.name = NULL;
  3300.     }
  3301. }
  3302.  
  3303. void
  3304. file_prin1 (LISP ptr, struct gen_printio *f)
  3305. {
  3306.   char *name;
  3307.   name = ptr->storage_as.c_file.name;
  3308.   gput_st (f, "#<FILE ");
  3309.   sprintf (tkbuffer, " %p", ptr->storage_as.c_file.f);
  3310.   gput_st (f, tkbuffer);
  3311.   if (name)
  3312.     {
  3313.       gput_st (f, " ");
  3314.       gput_st (f, name);
  3315.     }
  3316.   gput_st (f, ">");
  3317. }
  3318.  
  3319. FILE *
  3320. get_c_file (LISP p, FILE * deflt)
  3321. {
  3322.   if (NULLP (p) && deflt)
  3323.     return (deflt);
  3324.   if NTYPEP
  3325.     (p, tc_c_file) my_err ("not a file", p);
  3326.   if (!p->storage_as.c_file.f)
  3327.     my_err ("file is closed", p);
  3328.   return (p->storage_as.c_file.f);
  3329. }
  3330.  
  3331. LISP
  3332. lgetc (LISP p)
  3333. {
  3334.   int i;
  3335.   i = f_getc (get_c_file (p, stdin));
  3336.   return ((i == EOF) ? NIL : flocons ((double) i));
  3337. }
  3338.  
  3339. LISP
  3340. lungetc (LISP ii, LISP p)
  3341. {
  3342.   int i;
  3343.   if NNULLP
  3344.     (ii)
  3345.     {
  3346.       i = get_c_long (ii);
  3347.       f_ungetc (i, get_c_file (p, stdin));
  3348.     }
  3349.   return (NIL);
  3350. }
  3351.  
  3352. LISP
  3353. lputc (LISP c, LISP p)
  3354. {
  3355.   long flag;
  3356.   int i;
  3357.   FILE *f;
  3358.   f = get_c_file (p, siod_output);
  3359.   if FLONUMP
  3360.     (c)
  3361.       i = (int) FLONM (c);
  3362.   else
  3363.     i = *get_c_string (c);
  3364.   flag = no_interrupt (1);
  3365.   putc (i, f);
  3366.   no_interrupt (flag);
  3367.   return (NIL);
  3368. }
  3369.  
  3370. LISP
  3371. lputs (LISP str, LISP p)
  3372. {
  3373.   fput_st (get_c_file (p, siod_output), get_c_string (str));
  3374.   return (NIL);
  3375. }
  3376.  
  3377. LISP
  3378. lftell (LISP file)
  3379. {
  3380.   return (flocons ((double) ftell (get_c_file (file, NULL))));
  3381. }
  3382.  
  3383. LISP
  3384. lfseek (LISP file, LISP offset, LISP direction)
  3385. {
  3386.   return ((fseek (get_c_file (file, NULL), get_c_long (offset), get_c_long (direction)))
  3387.       ? NIL : sym_t);
  3388. }
  3389.  
  3390. LISP
  3391. parse_number (LISP x)
  3392. {
  3393.   char *c;
  3394.   c = get_c_string (x);
  3395.   return (flocons (atof (c)));
  3396. }
  3397.  
  3398. void
  3399. init_subrs (void)
  3400. {
  3401.   init_subrs_1 ();
  3402.   init_subrs_a ();
  3403. }
  3404.  
  3405. LISP
  3406. closure_code (LISP exp)
  3407. {
  3408.   return (exp->storage_as.closure.code);
  3409. }
  3410.  
  3411. LISP
  3412. closure_env (LISP exp)
  3413. {
  3414.   return (exp->storage_as.closure.env);
  3415. }
  3416.  
  3417. LISP
  3418. lwhile (LISP form, LISP env)
  3419. {
  3420.   LISP l;
  3421.   while (NNULLP (leval (car (form), env)))
  3422.     for (l = cdr (form); NNULLP (l); l = cdr (l))
  3423.       leval (car (l), env);
  3424.   return (NIL);
  3425. }
  3426.  
  3427. LISP
  3428. nreverse (LISP x)
  3429. {
  3430.   LISP newp, oldp, nextp;
  3431.   newp = NIL;
  3432.   for (oldp = x; CONSP (oldp); oldp = nextp)
  3433.     {
  3434.       nextp = CDR (oldp);
  3435.       CDR (oldp) = newp;
  3436.       newp = oldp;
  3437.     }
  3438.   return (newp);
  3439. }
  3440.  
  3441. LISP
  3442. siod_verbose (LISP arg)
  3443. {
  3444.   if NNULLP
  3445.     (arg)
  3446.       siod_verbose_level = get_c_long (car (arg));
  3447.   return (flocons (siod_verbose_level));
  3448. }
  3449.  
  3450. int
  3451. siod_verbose_check (int level)
  3452. {
  3453.   return ((siod_verbose_level >= level) ? 1 : 0);
  3454. }
  3455.  
  3456. LISP
  3457. lruntime (void)
  3458. {
  3459.   return (cons (flocons (myruntime ()),
  3460.         cons (flocons (gc_time_taken), NIL)));
  3461. }
  3462.  
  3463. LISP
  3464. lrealtime (void)
  3465. {
  3466.   return (flocons (myrealtime ()));
  3467. }
  3468.  
  3469. LISP
  3470. caar (LISP x)
  3471. {
  3472.   return (car (car (x)));
  3473. }
  3474.  
  3475. LISP
  3476. cadr (LISP x)
  3477. {
  3478.   return (car (cdr (x)));
  3479. }
  3480.  
  3481. LISP
  3482. cdar (LISP x)
  3483. {
  3484.   return (cdr (car (x)));
  3485. }
  3486.  
  3487. LISP
  3488. cddr (LISP x)
  3489. {
  3490.   return (cdr (cdr (x)));
  3491. }
  3492.  
  3493. LISP
  3494. lrand (LISP m)
  3495. {
  3496.   long res;
  3497.   res = rand ();
  3498.   if NULLP
  3499.     (m)
  3500.       return (flocons (res));
  3501.   else
  3502.     return (flocons (res % get_c_long (m)));
  3503. }
  3504.  
  3505. LISP
  3506. lsrand (LISP s)
  3507. {
  3508.   srand (get_c_long (s));
  3509.   return (NIL);
  3510. }
  3511.  
  3512. LISP
  3513. a_true_value (void)
  3514. {
  3515.   return (sym_t);
  3516. }
  3517.  
  3518. LISP
  3519. poparg (LISP * ptr, LISP defaultv)
  3520. {
  3521.   LISP value;
  3522.   if NULLP
  3523.     (*ptr)
  3524.       return (defaultv);
  3525.   value = car (*ptr);
  3526.   *ptr = cdr (*ptr);
  3527.   return (value);
  3528. }
  3529.  
  3530. char *
  3531. last_c_errmsg (int num)
  3532. {
  3533.   int xerrno = (num < 0) ? errno : num;
  3534.   static char serrmsg[100];
  3535.   char *errmsg;
  3536.   errmsg = g_strerror (xerrno);
  3537.   if (!errmsg)
  3538.     {
  3539.       sprintf (serrmsg, "errno %d", xerrno);
  3540.       errmsg = serrmsg;
  3541.     }
  3542.   return (errmsg);
  3543. }
  3544.  
  3545. LISP
  3546. llast_c_errmsg (int num)
  3547. {
  3548.   int xerrno = (num < 0) ? errno : num;
  3549.   char *errmsg = g_strerror (xerrno);
  3550.   if (!errmsg)
  3551.     return (flocons (xerrno));
  3552.   return (cintern (errmsg));
  3553. }
  3554.  
  3555. LISP
  3556. lllast_c_errmsg (void)
  3557. {
  3558.   return (llast_c_errmsg (-1));
  3559. }
  3560.  
  3561. LISP
  3562. help (void)
  3563. {
  3564.   fprintf (siod_output, "HELP for SIOD, Version %s\n", siod_version ());
  3565.   fprintf (siod_output, "For the latest Script-Fu tips, tutorials, & info:\n");
  3566.   fprintf (siod_output, "\thttp://www.gimp.org/scripts.html\n\n");
  3567.  
  3568.   return NIL;
  3569. }
  3570.  
  3571. size_t
  3572. safe_strlen (const char *s, size_t size)
  3573. {
  3574.   char *end;
  3575.   if ((end = (char *) memchr (s, 0, size)))
  3576.     return (end - s);
  3577.   else
  3578.     return (size);
  3579. }
  3580.  
  3581. char *
  3582. safe_strcpy (char *s1, size_t size1, const char *s2)
  3583. {
  3584.   size_t len2;
  3585.   if (size1 == 0)
  3586.     return (s1);
  3587.   len2 = strlen (s2);
  3588.   if (len2 < size1)
  3589.     {
  3590.       if (len2)
  3591.     memcpy (s1, s2, len2);
  3592.       s1[len2] = 0;
  3593.     }
  3594.   else
  3595.     {
  3596.       memcpy (s1, s2, size1);
  3597.       s1[size1 - 1] = 0;
  3598.     }
  3599.   return (s1);
  3600. }
  3601.  
  3602. char *
  3603. safe_strcat (char *s1, size_t size1, const char *s2)
  3604. {
  3605.   size_t len1;
  3606.   len1 = safe_strlen (s1, size1);
  3607.   safe_strcpy (&s1[len1], size1 - len1, s2);
  3608.   return (s1);
  3609. }
  3610.  
  3611. static LISP
  3612. parser_read (LISP ignore)
  3613. {
  3614.   return (leval (cintern ("read"), NIL));
  3615. }
  3616.  
  3617. void
  3618. init_subrs_1 (void)
  3619. {
  3620.   init_subr_2 ("cons", cons);
  3621.   init_subr_1 ("car", car);
  3622.   init_subr_1 ("cdr", cdr);
  3623.   init_subr_2 ("set-car!", setcar);
  3624.   init_subr_2 ("set-cdr!", setcdr);
  3625.   init_subr_2n ("+", plus);
  3626.   init_subr_2n ("-", difference);
  3627.   init_subr_2n ("*", ltimes);
  3628.   init_subr_2n ("/", Quotient);
  3629.   init_subr_2n ("min", lmin);
  3630.   init_subr_2n ("max", lmax);
  3631.   init_subr_1 ("abs", lllabs);
  3632.   init_subr_1 ("sqrt", lsqrt);
  3633.   init_subr_2 (">", greaterp);
  3634.   init_subr_2 ("<", lessp);
  3635.   init_subr_2 (">=", greaterEp);
  3636.   init_subr_2 ("<=", lessEp);
  3637.   init_subr_2 ("eq?", eq);
  3638.   init_subr_2 ("eqv?", eql);
  3639.   init_subr_2 ("=", eql);
  3640.   init_subr_2 ("assq", assq);
  3641.   init_subr_2 ("delq", delq);
  3642.   init_subr_1 ("read", lread);
  3643.   init_subr_1 ("parser_read", parser_read);
  3644.   setvar (cintern ("*parser_read.scm-loaded*"), sym_t, NIL);
  3645.   init_subr_0 ("eof-val", get_eof_val);
  3646.   init_subr_2 ("print", lprint);
  3647.   init_subr_2 ("prin1", lprin1);
  3648.   init_subr_2 ("eval", leval);
  3649.   init_subr_2 ("apply", lapply);
  3650.   init_fsubr ("define", leval_define);
  3651.   init_fsubr ("lambda", leval_lambda);
  3652.   init_msubr ("if", leval_if);
  3653.   init_fsubr ("while", leval_while);
  3654.   init_msubr ("begin", leval_progn);
  3655.   init_fsubr ("set!", leval_setq);
  3656.   init_msubr ("or", leval_or);
  3657.   init_msubr ("and", leval_and);
  3658.   init_fsubr ("*catch", leval_catch);
  3659.   init_subr_2 ("*throw", lthrow);
  3660.   init_fsubr ("quote", leval_quote);
  3661.   init_lsubr ("apropos", apropos);
  3662.   init_lsubr ("verbose", siod_verbose);
  3663.   init_subr_1 ("copy-list", copy_list);
  3664.   init_lsubr ("gc-status", gc_status);
  3665.   init_lsubr ("gc", user_gc);
  3666.   init_subr_3 ("load", load);
  3667.   init_subr_1 ("require", require);
  3668.   init_subr_1 ("pair?", consp);
  3669.   init_subr_1 ("symbol?", symbolp);
  3670.   init_subr_1 ("number?", numberp);
  3671.   init_msubr ("let-internal", leval_let);
  3672.   init_subr_1 ("let-internal-macro", let_macro);
  3673.   init_subr_1 ("let*-macro", letstar_macro);
  3674.   init_subr_1 ("letrec-macro", letrec_macro);
  3675.   init_subr_2 ("symbol-bound?", symbol_boundp);
  3676.   init_subr_2 ("symbol-value", symbol_value);
  3677.   init_subr_3 ("set-symbol-value!", setvar);
  3678.   init_fsubr ("the-environment", leval_tenv);
  3679.   init_subr_2 ("error", lerr);
  3680.   init_subr_0 ("quit", quit);
  3681.   init_subr_1 ("not", nullp);
  3682.   init_subr_1 ("null?", nullp);
  3683.   init_subr_2 ("env-lookup", envlookup);
  3684.   init_subr_1 ("reverse", reverse);
  3685.   init_lsubr ("symbolconc", symbolconc);
  3686.   init_subr_3 ("save-forms", save_forms);
  3687.   init_subr_2 ("fopen", fopen_l);
  3688.   init_subr_1 ("fclose", fclose_l);
  3689.   init_subr_1 ("getc", lgetc);
  3690.   init_subr_2 ("ungetc", lungetc);
  3691.   init_subr_2 ("putc", lputc);
  3692.   init_subr_2 ("puts", lputs);
  3693.   init_subr_1 ("ftell", lftell);
  3694.   init_subr_3 ("fseek", lfseek);
  3695.   init_subr_1 ("parse-number", parse_number);
  3696.   init_subr_2 ("%%stack-limit", stack_limit);
  3697.   init_subr_1 ("intern", intern);
  3698.   init_subr_2 ("%%closure", closure);
  3699.   init_subr_1 ("%%closure-code", closure_code);
  3700.   init_subr_1 ("%%closure-env", closure_env);
  3701.   init_fsubr ("while", lwhile);
  3702.   init_subr_1 ("nreverse", nreverse);
  3703.   init_subr_0 ("allocate-heap", allocate_aheap);
  3704.   init_subr_1 ("gc-info", gc_info);
  3705.   init_subr_0 ("runtime", lruntime);
  3706.   init_subr_0 ("realtime", lrealtime);
  3707.   init_subr_1 ("caar", caar);
  3708.   init_subr_1 ("cadr", cadr);
  3709.   init_subr_1 ("cdar", cdar);
  3710.   init_subr_1 ("cddr", cddr);
  3711.   init_subr_1 ("rand", lrand);
  3712.   init_subr_1 ("srand", lsrand);
  3713.   init_subr_0 ("last-c-error", lllast_c_errmsg);
  3714.   init_subr_0 ("help", help);
  3715.   init_slib_version ();
  3716. }
  3717.  
  3718.  
  3719. /* err0,pr,prp are convenient to call from the C-language debugger */
  3720.  
  3721. void
  3722. err0 (void)
  3723. {
  3724.   my_err ("0", NIL);
  3725. }
  3726.  
  3727. void
  3728. pr (LISP p)
  3729. {
  3730.   if (looks_pointerp (p))
  3731.     lprint (p, NIL);
  3732.   else
  3733.     put_st ("invalid\n");
  3734. }
  3735.  
  3736. void
  3737. prp (LISP * p)
  3738. {
  3739.   if (!p)
  3740.     return;
  3741.   pr (*p);
  3742. }
  3743.