home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / wool.c < prev    next >
C/C++ Source or Header  |  1995-07-03  |  50KB  |  2,163 lines
  1.  
  2. /* Copyright 1989 GROUPE BULL -- See license conditions in file COPYRIGHT
  3.  * Copyright 1989 Massachusetts Institute of Technology
  4.  */
  5. /**************************************************************\
  6. *                                    *
  7. * WOOL.c:                               *
  8. * main body of interpreter                       *
  9. *                                    *
  10. * Here are defined Wool-only functions.                   *
  11. * To add a function:                           *
  12. *     - declare it (coded in or extern)               *
  13. *     - add it to the declaration of predefined functions    *
  14. *       in the wool_init function                   *
  15. *                                    *
  16. * 'Kludged' to support the flex skeleton parser for V2.3.7   *
  17. *                Dec 1992, O. Kirch           *
  18. \**************************************************************/
  19.  
  20. #if defined SVR4
  21. #define SYSV
  22. #endif
  23.  
  24. #include <stdio.h>
  25. #include <sys/types.h>
  26. #include <sys/file.h> 
  27. #include <sys/times.h>
  28. #include <signal.h> 
  29. #include <sys/stat.h>
  30. #if defined(IBM_RT) && defined(SYSV)
  31. #include <unistd.h>
  32. #endif /* IBM_RT && SYSV */
  33. #if defined(i386) || defined(stellar)
  34. #include <unistd.h>
  35. #endif /* i386 */
  36. #if defined(sun) && defined(SYSV)
  37. #include <unistd.h>
  38. #endif /* sun && SYSV */
  39. #if defined(linux)
  40. #include <unistd.h>
  41. #endif /* linux */
  42. #if defined(SYSV)
  43. #include <limits.h>
  44. #endif
  45.  
  46. #include "INTERN.h"
  47. #include "wool.h"
  48. #include "EXTERN.h"
  49. #include "wl_atom.h"
  50. #include "wl_coll.h"
  51. #include "wl_func.h"
  52. #include "wl_list.h"
  53. #include "wl_number.h"
  54. #include "wl_string.h"
  55. #include "wl_pointer.h"
  56. #include "wl_active.h"
  57. #include "wl_name.h"
  58. #include "yacc.h"
  59.  
  60. #ifdef SYSV
  61. #include <string.h>
  62. #include <sys/utsname.h>
  63. #else /* SYSV */
  64. #include <sys/wait.h>
  65. #include <strings.h>
  66. #include <sys/timeb.h>
  67. #endif /* SYSV */
  68.  
  69. #ifdef STATS
  70. extern WOOL_OBJECT zrtstats();
  71. extern WOOL_OBJECT wlcfstats();
  72. #endif /* STATS */
  73. extern WOOL_OBJECT progn();
  74. extern WOOL_OBJECT wool_print_nary();
  75. extern WOOL_OBJECT wool_with(), wool_with_eval(); 
  76. extern int     wool_error_in_profile;
  77. extern char     *yytext;
  78. DECLARE_strchr;
  79.  
  80. #ifdef DEBUG
  81. #ifdef GWM
  82. extern WOOL_OBJECT WLFsm_fp();
  83. extern WOOL_OBJECT WLState_fp();
  84. extern WOOL_OBJECT WLArc_fp();
  85. #endif /* GWM */
  86. #endif /* DEBUG */
  87.  
  88. /* VARS */
  89.  
  90. #ifdef SECURE
  91. /* some helps */
  92. char *wool_methods_names[] = {
  93.     "WOOL_type_name",
  94.     "WOOL_eval",
  95.     "WOOL_print",
  96.     "WOOL_free",
  97.     "WOOL_execute",
  98.     "WOOL_set",
  99.     "WOOL_get_C_value",
  100.     "WOOL_open",
  101.     "WOOL_close",
  102.     "WOOL_process_event",
  103.     "WOOL_copy",
  104.     "WOOL_get_dimensions",
  105.     "WOOL_draw",
  106.     "WOOL_equal",
  107.     "WOOL_reconfigure",
  108.     "WOOL_setq",
  109.     "WOOL_silent_eval",
  110.     "WOOL_UNDEFINED",
  111.     "WOOL_UNDEFINED",
  112.     "WOOL_UNDEFINED",
  113.     "WOOL_UNDEFINED"
  114. };
  115.  
  116. #endif /* SECURE */
  117.  
  118. #ifdef DO_BUS_ERROR
  119. #define DoABusError() *((int *)0) = 1
  120. #else /* DO_BUS_ERROR */
  121. #define DoABusError()
  122. #endif /* DO_BUS_ERROR */
  123.  
  124. /*
  125.  * all constructors sets reference count of the object to 0
  126.  * You should call check_reference on this object if it was only
  127.  * a temporary one!
  128.  */
  129.  
  130. /*******************\
  131. *             *
  132. *  run-time errors  *
  133. *             *
  134. \*******************/
  135.  
  136. static int             wool_error_position;
  137. static char           *wool_error_expecting;
  138. static int           wool_error_print_argc;
  139. static WOOL_OBJECT    *wool_error_print_argv;
  140.  
  141. /* echoes 1st, 2nd, 3rd, nth */
  142.  
  143. char *
  144. English_enumeration_postfix(n)
  145. int n;
  146. {
  147.     switch (n) {
  148.     case 1: return "st";
  149.     case 2: return "nd";
  150.     case 3: return "rd";
  151.     default: return "th";
  152.     }
  153. }
  154.  
  155. #ifdef __STDC__
  156. extern void wool_print_error_message(int error, const void *message, char *text);
  157. #else
  158. extern void wool_print_error_message();
  159. #endif
  160.  
  161. /*
  162.  * wool_error:
  163.  * This is the standard error function. It is really brutal, as it wool_prints
  164.  * an error message an then LONGJMPs to "wool_goes_here_on_error" with an
  165.  * error value, for now 1.
  166.  * You can feel free to redefine wool_goes_here_on_error.
  167.  * 
  168.  * WARNING: Don't forget to clean your structures before going here,
  169.  * you won't return!
  170.  */
  171.  
  172. WOOL_OBJECT
  173. #ifdef __STDC__
  174. _wool_error(int error, const void *message)
  175. #else
  176. _wool_error(error, message)
  177. int             error;        /* error number (see wool.h) */
  178. char           *message;    /* anything, in fact */
  179. #endif
  180. {
  181.     static int      is_in_wool_error;
  182.  
  183.     if (is_in_wool_error) {
  184.     stop_if_in_dbx();
  185.     goto direct_longjmp;
  186.     }
  187.     is_in_wool_error = 1;
  188.     if (wool_do_print_errors && error != SILENT_ERROR) {
  189.     wool_print_error_message(error, message, "WOOL ERROR: ");
  190.     wool_stack_dump(0);
  191.     fflush(stdout);
  192.     fflush(stderr);
  193.     }
  194.     if (!wool_continue_reading_on_error)
  195.     wool_error_status = 1;
  196.     wool_error_handler();        /* C package handler */
  197.     DoABusError();            /* debug only */
  198.     WLStackFrame_pop_to(wool_stackframe_on_error);
  199.     calling_function_current = calling_function_stack +
  200.     calling_function_on_error;
  201. direct_longjmp:
  202.     is_in_wool_error = 0;
  203.     stop_if_in_dbx();
  204.     longjmp(wool_goes_here_on_error, 1);
  205.     /* NOTREACHED *//* for lint */
  206.     return NIL;
  207. }
  208.  
  209. void
  210. #ifdef __STDC__
  211. wool_print_error_message(int error, const void *message, char *text)
  212. #else
  213. wool_print_error_message(error, message, text)
  214. int             error;        /* error number (see wool.h) */
  215. char           *message;    /* anything, in fact */
  216. char           *text;        /* WOOL ERROR: */
  217. #endif
  218. {
  219. #ifndef DEBUG
  220.     wool_newline();
  221. #endif /* DEBUG */
  222.     if (wool_is_reading_file) {
  223.     wool_printf("\"%s\"", wool_is_reading_file);
  224.     wool_printf(": line %d\n", yylineno);
  225.     }
  226.     wool_puts(text);
  227.     switch (error) {
  228.     case UNDEFINED_VARIABLE:
  229.     wool_printf("undefined variable: %s", message);
  230.     break;
  231.     case BAD_NUMBER_OF_ARGS:
  232.     wool_printf("bad number of arguments %d", message);
  233.     break;
  234.     case UNDEFINED_FUNCTION:
  235.     wool_puts("undefined function: ");
  236.     wool_print(message);
  237.     break;
  238.     case BAD_DEFUN:
  239.     wool_printf("bad definition of function: %s", message);
  240.     break;
  241.     case BAD_ARG_TYPE:
  242.     wool_printf("bad %d", wool_error_position + 1);
  243.     wool_printf("%s argument: ",
  244.             English_enumeration_postfix(wool_error_position + 1));
  245.     wool_print(message);
  246.     if (wool_error_expecting) {
  247.         wool_puts(" (its type is \"");
  248.         wool_print(((WOOL_OBJECT) message) -> type[0]);
  249.         if (wool_error_expecting[0])
  250.           wool_printf("\", was expecting a \"%s",
  251.               wool_error_expecting);
  252.         wool_puts("\")");
  253.     }
  254.     break;
  255.     case RELEASING_ATOM:
  256.     wool_printf("Internal error: trying to free atom: %s", message);
  257.     break;
  258.     case NOT_AN_ATOM:
  259.     wool_printf("Not an atom: %s", message);
  260.     break;
  261.     case BAD_LOCAL_SYNTAX:
  262.     wool_printf("bad local variable declaration. %s", message);
  263.     break;
  264.     case SYNTAX_ERROR:
  265.     wool_printf("%s", message);
  266.     break;
  267.     case INTERNAL_ERROR:
  268.     wool_printf("Internal error: %s", message);
  269.     break;
  270.     case TIME_EXCEEDED:
  271.     wool_printf("Evaluation took longer than %ld second(s) -- Aborted",
  272.             message);
  273.     break;
  274.     case CANNOT_SET:
  275.     wool_puts("Cannot set a \"");
  276.     wool_print_type(message);
  277.     wool_puts("\": ");
  278.     wool_print(message);
  279.     break;
  280.     case CANNOT_GET_C_VALUE:
  281.     wool_puts("Cannot figure how to get a number from a \"");
  282.     wool_print_type(message);
  283.     wool_puts("\": ");
  284.     wool_print(message);
  285.     break;
  286.     case TOO_MANY_PARAMETERS:
  287.     wool_puts("Too many parameters for a C function call: ");
  288.     wool_print(message);
  289.     break;
  290.     case NON_WOOL_OBJECT:
  291.     wool_printf("%s on a non wool object.", message);
  292.     break;
  293.     case UNDEFINED_METHOD:
  294. #ifdef DEBUG
  295.     wool_printf("Undef WOOL method %s for type \"",
  296.             wool_methods_names[WOOL_current_method]);
  297. #else /* DEBUG */
  298.     wool_puts("Bad object type \"");
  299. #endif /* DEBUG */
  300.     WLAtom_print(((WOOL_OBJECT) message) -> type[0]);
  301.     wool_puts("\" for object: ");
  302.     wool_print(message);
  303.     break;
  304.     case NO_MEMORY:
  305.     wool_puts("No more memory, bye...\n");
  306.     wool_end(1);
  307.     break;
  308.     case NOT_REDEFINABLE:
  309.     wool_puts("Cannot redefine object: ");
  310.     wool_print(message);
  311.     break;
  312.     case NOT_MODIFIABLE:
  313.     wool_puts("Cannot modify object: ");
  314.     wool_print(message);
  315.     break;
  316.     case USER_ERROR:
  317.     wool_print_nary(wool_error_print_argc, wool_error_print_argv);
  318.     break;
  319.     default:            /* suppose first arg was a string! */
  320.     wool_printf(error, message);
  321.     }
  322.     wool_newline();
  323. }
  324.  
  325. /* wool_trigger_error
  326.  * triggers an error from wool
  327.  */
  328.  
  329. WOOL_OBJECT
  330. wool_trigger_error(argc, argv)
  331. int argc;
  332. WOOL_OBJECT    argv[];
  333. {
  334.     wool_error_print_argc = argc;
  335.     wool_error_print_argv = argv;
  336.     return wool_error(USER_ERROR, 0);
  337. }
  338.  
  339. /* wool_error_has_occurred:
  340.  * encapsulates statements to trap errors without printing them
  341.  */
  342.  
  343. WOOL_OBJECT
  344. wool_error_has_occurred(argc, argv)
  345. int argc;
  346. WOOL_OBJECT    argv[];
  347. {
  348.     int             we_got_an_error = 0;
  349.     int old_wool_do_print_errors = wool_do_print_errors;
  350.  
  351.     save_wool_error_resume_point();
  352.     wool_do_print_errors = 0;
  353.     if (set_wool_error_resume_point()) {
  354.     we_got_an_error = 1;
  355.     } else {
  356.     progn(argc, argv);
  357.     }
  358.     wool_do_print_errors = old_wool_do_print_errors;
  359.     restore_wool_error_resume_point();
  360.     return (we_got_an_error ? TRU : NIL);
  361. }
  362.  
  363. /* bad argument call
  364.  */
  365.  
  366. WOOL_OBJECT
  367. bad_argument(argument, position, expecting)
  368. WOOL_OBJECT    argument;
  369. int        position;
  370. char           *expecting;
  371. {
  372.     wool_error_position = position;
  373.     wool_error_expecting = expecting;
  374.     return wool_error(BAD_ARG_TYPE, argument);
  375. }
  376.  
  377. /* wool warning messages 
  378.  * returns 1 if printed
  379.  */
  380.  
  381. int
  382. wool_warning(alarm_text)
  383. char    *alarm_text;
  384. {
  385.     if(wool_do_print_errors){
  386.     wool_puts(alarm_text);
  387.     if (wool_is_reading_file) {
  388.         wool_printf("\"%s\"", wool_is_reading_file);
  389.         wool_printf(": line %d, ", yylineno);
  390.     }
  391.     wool_stack_dump(0);
  392.     return 1;
  393.     } else
  394.         return 0;
  395. }
  396.  
  397. int
  398. wool_warning1(alarm_text, data)
  399. char    *alarm_text;
  400. char    *data;
  401. {
  402.     char msg[MAX_TEMP_STRING_SIZE];
  403.  
  404.     sprintf(msg, alarm_text, data);
  405.     return wool_warning(msg);
  406. }
  407.  
  408.  
  409. /* executes an expression, returns if error (do not jump to toplevel)
  410.  * return eval if no error occurred, NULL otherwise
  411.  */
  412.  
  413. WOOL_OBJECT
  414. wool_eval_and_catch_errors(wool_expr)
  415. WOOL_OBJECT wool_expr;
  416. {
  417.     WOOL_OBJECT        result = 0;
  418.  
  419.     save_wool_error_resume_point();    /* contains decls */
  420.     if (set_wool_error_resume_point()) {
  421.     result = 0;
  422.     } else {
  423.     result = WOOL_send(WOOL_eval, wool_expr, (wool_expr));
  424.     }
  425.     restore_wool_error_resume_point();
  426.     return  result;
  427. }
  428.  
  429. /* same but do not return a value
  430.  */
  431.  
  432. wool_eval_and_catch_errors_proc(wool_expr)
  433. WOOL_OBJECT wool_expr;
  434. {
  435.     int             local_zrt_size = zrt_size;
  436.  
  437.     wool_eval_and_catch_errors(wool_expr);
  438.     zrt_gc(local_zrt_size);
  439. }
  440.   
  441.  
  442. /* 
  443.  * undefined method, one for each number of parameters.
  444.  */
  445.  
  446. WOOL_OBJECT
  447. wool_undefined_method_1(object)
  448. WOOL_OBJECT object;
  449. {
  450.     return wool_error(UNDEFINED_METHOD, object);
  451. }
  452.  
  453. WOOL_OBJECT
  454. wool_undefined_method_2(object, param1)
  455. WOOL_OBJECT object;
  456. WOOL_OBJECT param1;
  457. {
  458.     return wool_error(UNDEFINED_METHOD, object);
  459. }
  460.  
  461. #ifdef DEBUG
  462. #define RMAGIC        0x5555    /* magic # on range info (see malloc.c)*/
  463.  
  464. extern char *malloc_zone_begin, *malloc_zone_end;
  465.  
  466. wool_send_is_valid(message, object)
  467. int message;
  468. WOOL_OBJECT object;
  469. {
  470.     if (!object
  471.     || ((char *) object) < malloc_zone_begin
  472.     || ((char *) object) >= malloc_zone_end
  473.     || *((int *) object) == FREED_MAGIC
  474.     || ((((WOOL_Atom) object -> type[0]) -> type != WLAtom)
  475.         && (((WOOL_Atom) object -> type[0]) -> type != WLActive)
  476.         && (((WOOL_Atom) object -> type[0]) -> type != WLPointer)
  477.         && (((WOOL_Atom) object -> type[0]) -> type != WLName)))
  478.     wool_error(NON_WOOL_OBJECT, wool_methods_names[message]);
  479. }
  480.  
  481. wool_object_is_valid(object)
  482. WOOL_OBJECT object;
  483. {
  484.     if (!object
  485.     || ((char *) object) < malloc_zone_begin
  486.     || ((char *) object) >= malloc_zone_end
  487.     || *((int *) object) == FREED_MAGIC
  488.     || ((((WOOL_Atom) object -> type[0]) -> type != WLAtom)
  489.         && (((WOOL_Atom) object -> type[0]) -> type != WLActive)
  490.         && (((WOOL_Atom) object -> type[0]) -> type != WLPointer)
  491.         && (((WOOL_Atom) object -> type[0]) -> type != WLName)))
  492.     return 0;
  493.     else
  494.     return 1;
  495. }
  496.  
  497. #endif /* DEBUG */
  498.  
  499. /*********************************************************\
  500. *                               *
  501. * The definition of C WOOL routines              *
  502. * These constitue the WOOL interface to the C programmer  *
  503. *                               *
  504. \*********************************************************/
  505.  
  506. /*
  507.  * wool_read:
  508.  * reads an expression from the input (string or stream).
  509.  * returns this expression or NULL if EOF reached
  510.  * In case of syntax error, returns NIL
  511.  * the read expression is in the global variable wool_read_expr,
  512.  * if you need it. (this global is maintained for ref count purposes)
  513.  * You don't need to free it since it's done at the beginning of this
  514.  * routine.
  515.  * Beware that it could be overwritten by a subsequent call to wool_eval
  516.  * or wool_read !
  517.  */
  518.  
  519. WOOL_OBJECT
  520. wool_read()
  521. {
  522.     if (yyparse())
  523.     return NULL;        /* returns NULL if error */
  524.     else
  525.     return wool_read_expr;    /* returns parsed expression */
  526. }
  527.  
  528. /*
  529.  * wool_pool:
  530.  * this routine MUST be used when you want to make successive calls to
  531.  * wool_read to parse an expression. It stores the string passed as argument
  532.  * and returns the parenthese level. Thus a normal use would be to call
  533.  * wool_pool with successive lines, while it returns a non-zero value,
  534.  * and then call wool_read on the pooled buffer maintained by wool_poll,
  535.  * whose address is stored in the global wool_pool_buffer.
  536.  * (the parenthese level is in the int wool_pool_parenthese_level)
  537.  * The buffer is reset by calling wool_pool with a NULL argument.
  538.  */
  539.  
  540. int
  541. wool_pool(s)
  542. char           *s;        /* the string to be put in the pool */
  543. {
  544.     int             required_length;
  545.  
  546.     if (!wool_pool_buffer)
  547.     wool_pool_buffer =
  548.         (char *) Malloc(wool_pool_buffer_size);
  549.     if (!s) {
  550.     *wool_pool_buffer = '\0';
  551.     return wool_pool_parentheses_level = 0;
  552.     } else {
  553.     if ((int) (strlen(wool_pool_buffer) + (required_length = strlen(s)))
  554.         >= wool_pool_buffer_size) {
  555.         wool_pool_buffer_size +=
  556.         Max(wool_pool_buffer_size, required_length) + 4;
  557.         wool_pool_buffer = (char *)
  558.         Realloc(wool_pool_buffer, wool_pool_buffer_size);
  559.     }
  560.     strcat(wool_pool_buffer, "\n");
  561.     strcat(wool_pool_buffer, s);
  562.     {
  563.         char           *oldstream, old_input_buf[AHEAD_BUF_SIZE];
  564.         int             old_type;
  565.  
  566.         old_type = wool_input_redirect(1, s, &oldstream, old_input_buf);
  567.         while (yylex() != END_OF_FILE);
  568.         wool_input_redirect(old_type, oldstream, NULL, NULL);
  569.         wool_unput(old_input_buf);
  570.         return wool_pool_parentheses_level;
  571.     }
  572.     }
  573. }
  574.  
  575. /*
  576.  * wool_eval:
  577.  * evals an expression given as argument;
  578.  * returns the result of the evaluation
  579.  * if you want to keep the result, increase its reference count!
  580.  * In case of eval error, calls wool_error which returns NIL
  581.  */
  582.  
  583. WOOL_OBJECT
  584. wool_eval(read_expr)
  585. WOOL_OBJECT read_expr;
  586. {
  587.     return WOOL_send(WOOL_eval, read_expr, (read_expr));
  588. }
  589.  
  590. /***************************************************************************\
  591. *                                         *
  592. * WOOL USER routines:                                *
  593. * here are the definition of the standard routines binded to wool atoms by  *
  594. * wool_init                                    *
  595. *                                         *
  596. \***************************************************************************/
  597.  
  598. /*
  599.  * The NULL function is there only as a placeholder
  600.  */
  601.  
  602. WOOL_OBJECT
  603. NIL_FUNC()
  604. {
  605.     return NIL;
  606. }
  607.  
  608. /*
  609.  * quoting can be implemented as a function:
  610.  * 'foo ==> (quote foo)
  611.  */
  612.  
  613. WOOL_OBJECT
  614. wool_quote(obj)
  615. WOOL_OBJECT obj;
  616. {
  617.     return obj;
  618. }
  619.  
  620. /*
  621.  * eval is the opposite of quoting
  622.  */
  623.  
  624. WOOL_OBJECT
  625. eval(obj)
  626. WOOL_OBJECT     obj;
  627. {
  628.     return WOOL_send(WOOL_eval, obj, (obj));
  629. }
  630.  
  631. /* copy an object (useful for lists)
  632.  */
  633.  
  634. WOOL_OBJECT
  635. wool_copy(obj)
  636. WOOL_OBJECT     obj;
  637. {
  638.     return WOOL_send(WOOL_copy, obj, (obj));
  639. }
  640.  
  641. /*
  642.  * Arithmetic functions, patterned along Le_Lisp ones
  643.  */
  644.  
  645. WOOL_OBJECT
  646. wool_divide(n1, n2)
  647. WOOL_Number n1, n2;
  648. {
  649.     return (WOOL_OBJECT) WLNumber_make(n2 -> number ?
  650.                        n1 -> number / n2 -> number : 0);
  651. }
  652.  
  653. WOOL_OBJECT
  654. wool_modulo(n1, n2)
  655. WOOL_Number n1, n2;
  656. {
  657.     Num tmp = n2 -> number ? n1 -> number % n2 -> number : 0;
  658.     
  659.     if (tmp < 0)
  660.     tmp = tmp + n2 -> number;
  661.     
  662.     return (WOOL_OBJECT) WLNumber_make(tmp);
  663. }
  664.  
  665. WOOL_OBJECT
  666. wool_multiply(n1, n2)
  667. WOOL_Number n1, n2;
  668. {
  669.     return (WOOL_OBJECT) WLNumber_make(n1 -> number * n2 -> number);
  670. }
  671.  
  672. WOOL_OBJECT
  673. wool_add(argc,argv)
  674. int        argc;
  675. WOOL_Number     argv[];
  676. {
  677.     WOOL_TYPE       type;
  678.  
  679.     if (argc == 0)
  680.     wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
  681.     type = argv[0] -> type;
  682.     if (type == WLList || argv[0] == (WOOL_Number) NIL)
  683.     return WLList_concat(argc, argv);
  684.     else if (type == WLNumber)
  685.     return add_numbers(argc, argv);
  686.     else
  687.     must_be_string(argv[0], 0);
  688.     return add_strings(argc, argv);
  689. }
  690.  
  691. WOOL_OBJECT
  692. wool_minus(argc, argv)
  693. int        argc;
  694. WOOL_Number     argv[];
  695. {
  696.     switch (argc) {
  697.     case 1:
  698.     return (WOOL_OBJECT) WLNumber_make(-(argv[0] -> number));
  699.     case 2:
  700.     return (WOOL_OBJECT) WLNumber_make(
  701.                  (argv[0] -> number) - (argv[1] -> number));
  702.     case 0:
  703.     return wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
  704.     default: {int i, result = argv[0] -> number;
  705.           for (i = 1; i < argc; i++)
  706.           result -= argv[i] -> number;
  707.           return (WOOL_OBJECT) WLNumber_make(result);
  708.       }    
  709.     }
  710. }
  711.  
  712. /* comparisons
  713.  */
  714.  
  715. WOOL_OBJECT
  716. wool_equal(o1, o2)
  717. WOOL_OBJECT     o1, o2;
  718. {
  719.     return WOOL_send(WOOL_equal, o1, (o1, o2));
  720. }
  721.  
  722. WOOL_OBJECT
  723. wool_eq(o1, o2)
  724. WOOL_OBJECT     o1, o2;
  725. {
  726.     if (o1 == o2)
  727.     return TRU;
  728.     else
  729.     return NIL;
  730. }
  731.  
  732. WOOL_OBJECT
  733. greater_than(o1, o2)
  734. WOOL_OBJECT     o1, o2;
  735. {
  736.     if (o1 -> type != o2 -> type)
  737.     return NIL;
  738.     if (((o1 -> type == WLNumber) &&
  739.      (((WOOL_Number) o1) -> number > ((WOOL_Number) o2) -> number))
  740.     || ((o1 -> type == WLString) &&
  741.         strcmp(((WOOL_String) o1) -> string,
  742.            ((WOOL_String) o2) -> string) == 1))
  743.     return TRU;
  744.     else
  745.     return NIL;
  746. }
  747.  
  748. WOOL_OBJECT
  749. lesser_than(o1, o2)
  750. WOOL_OBJECT     o1, o2;
  751. {
  752.     if (o1 -> type != o2 -> type)
  753.     return NIL;
  754.     if (((o1 -> type == WLNumber) &&
  755.      (((WOOL_Number) o1) -> number < ((WOOL_Number) o2) -> number))
  756.     || ((o1 -> type == WLString) &&
  757.         strcmp(((WOOL_String) o1) -> string,
  758.            ((WOOL_String) o2) -> string) == -1))
  759.     return TRU;
  760.     else
  761.     return NIL;
  762. }
  763.     
  764. /* wool_compare returns -1, 0, +1 if <, =, > and () if not comparable.
  765.  */
  766.  
  767. WOOL_OBJECT
  768. wool_compare(o1, o2)
  769. WOOL_Number     o1, o2;
  770. {
  771.     if (o1 -> type != o2 -> type)
  772.     return NIL;
  773.     if (o1 -> type == WLNumber) {
  774.     if (o1 -> number < o2 -> number)
  775.         return (WOOL_OBJECT) WLNumber_make(-1);
  776.     else if (o1 -> number > o2 -> number)
  777.         return (WOOL_OBJECT) WLNumber_make(1);
  778.     else
  779.         return (WOOL_OBJECT) WLNumber_make(0);
  780.     } else {
  781.     must_be_string(o1, 0);
  782.     return (WOOL_OBJECT) WLNumber_make(
  783.                     strcmp(((WOOL_String) o1) -> string,
  784.                          ((WOOL_String) o2) -> string));
  785.     }
  786. }
  787.  
  788. /* member of a list, or substring of a string:
  789.  * returns position in list or string or NIL if not found
  790.  */
  791.  
  792. WOOL_OBJECT
  793. wool_member(obj, list)
  794. WOOL_String    obj;
  795. WOOL_List    list;
  796. {
  797.     if (list -> type == WLList) {    /* list */
  798.     WOOL_OBJECT    *p = list -> list;
  799.     WOOL_OBJECT    *last = p + list -> size;
  800.  
  801.     while (p < last) {
  802.         if (WOOL_send(WOOL_equal, obj, (obj, *p)) != NIL)
  803.         return (WOOL_OBJECT) WLNumber_make(p - list -> list);
  804.         p++;
  805.     }
  806.     return NIL;
  807.     } else if (list == (WOOL_List) NIL) {    /* () */
  808.     return NIL;
  809.     } else {                /* substring of a string */
  810.     char           *p, *string;
  811.     int             length;
  812.  
  813.     must_be_string(list, 1);
  814.     must_be_string(obj, 0);
  815.     string = ((WOOL_String) list) -> string;
  816.     length = strlen(obj -> string);
  817.     for (p = string; *p; p++)
  818.         if (!strncmp(obj -> string, p, length))
  819.         return (WOOL_OBJECT) WLNumber_make(p - string);
  820.     return NIL;
  821.     }
  822. }
  823.  
  824. /* logical operations
  825.  */
  826.  
  827. WOOL_OBJECT
  828. not(obj)
  829. WOOL_OBJECT     obj;
  830. {
  831.     if (obj == NIL)
  832.     return TRU;
  833.     else
  834.     return NIL;
  835. }
  836.  
  837. WOOL_OBJECT
  838. and(argc, argv)
  839. int        argc;
  840. WOOL_OBJECT     argv[];
  841. {
  842.     int    i;
  843.  
  844.     for (i = 0; i < argc; i++)
  845.     if (WOOL_send(WOOL_eval, argv[i], (argv[i])) == NIL)
  846.         return NIL;
  847.     return TRU;
  848. }
  849.  
  850. WOOL_OBJECT
  851. or(argc, argv)
  852. int        argc;
  853. WOOL_OBJECT     argv[];
  854. {
  855.     int    i;
  856.     WOOL_OBJECT tmp;
  857.  
  858.     for (i = 0; i < argc; i++)
  859.     if ((tmp = WOOL_send(WOOL_eval, argv[i], (argv[i]))) != NIL)
  860.         return tmp;
  861.     return NIL;
  862. }
  863.  
  864. /*
  865.  * bitwise-operators
  866.  */
  867.  
  868. WOOL_OBJECT
  869. wool_bitwise_or(argc, argv)
  870. int argc;
  871. WOOL_Number argv[];
  872. {
  873.     int             num = 0;
  874.  
  875.     while (argc--)
  876.     num |= argv[argc] -> number;
  877.     return (WOOL_OBJECT) WLNumber_make(num);
  878. }
  879.  
  880. WOOL_OBJECT
  881. wool_bitwise_and(argc, argv)
  882. int argc;
  883. WOOL_Number argv[];
  884. {
  885.     int             num = argv[0] -> number;
  886.  
  887.     while (argc--)
  888.     num &= argv[argc] -> number;
  889.     return (WOOL_OBJECT) WLNumber_make(num);
  890. }
  891.  
  892. WOOL_OBJECT
  893. wool_bitwise_xor(argc, argv)
  894. int argc;
  895. WOOL_Number argv[];
  896. {
  897.     int             num = 0;
  898.  
  899.     while (argc--)
  900.     num ^= argv[argc] -> number;
  901.     return (WOOL_OBJECT) WLNumber_make(num);
  902. }
  903.  
  904. /*
  905.  * Setq, the most important function
  906.  * implemented as a method
  907.  */
  908.  
  909. WOOL_OBJECT
  910. setq(atom, value)
  911. WOOL_Atom atom;
  912. WOOL_OBJECT value;
  913. {
  914.     return WOOL_send(WOOL_set, atom, (atom, value));
  915. }
  916.  
  917. WOOL_OBJECT
  918. set(atom, value)
  919. WOOL_Atom atom;
  920. WOOL_OBJECT value;
  921. {
  922.     return WOOL_send(WOOL_setq, atom, (atom, value));
  923. }
  924.  
  925. /*
  926.  * unbind: release storage of an atom
  927.  */
  928.  
  929. WOOL_OBJECT
  930. wool_unbind(atom)
  931. WOOL_Atom atom;
  932. {
  933.     extern WOOL_OBJECT WLAtom_unbind(), WLName_unbind();
  934.  
  935.     if (atom -> type == WLAtom)
  936.     return WLAtom_unbind(atom);
  937.     else if (atom -> type == WLName)
  938.     return WLName_unbind(atom);
  939.     else
  940.     return bad_argument(atom, 0, "atom or name");
  941. }
  942.  
  943. /*
  944.  * boundp: tests if atom has already be defined
  945.  */
  946.  
  947. WOOL_OBJECT
  948. wool_boundp(atom)
  949. WOOL_OBJECT atom;
  950. {
  951.     WOOL_OBJECT    value = WOOL_send(WOOL_silent_eval, atom, (atom));
  952.  
  953.     if (value && value != UNDEFINED_WOOL_VALUE)
  954.     return (atom == NIL ? TRU : atom);
  955.     else
  956.     return NIL;
  957. }
  958.  
  959. /*
  960.  * list: makes a list of its evaluated arguments
  961.  */
  962.  
  963. WOOL_OBJECT
  964. wool_list(argc, argv)
  965. int argc;
  966. WOOL_OBJECT     argv[];
  967. {
  968.     WOOL_List list;
  969.     WOOL_OBJECT *q, *last;
  970.  
  971.     if (!argc)
  972.     return NIL;
  973.     list = wool_list_make(argc);
  974.     q = list -> list;
  975.     last = argv + argc;
  976.  
  977.     while (argv < last)
  978.         increase_reference(*q++ = *argv++);
  979.     return (WOOL_OBJECT) list;
  980. }
  981.  
  982. /*
  983.  * length: of a string or list
  984.  */
  985.  
  986. WOOL_Number
  987. wool_length(obj)
  988. WOOL_List     obj;
  989. {
  990.     if (obj -> type == WLList)
  991.     return WLNumber_make(obj -> size);
  992.     else if (obj == (WOOL_List) NIL)
  993.     return WLNumber_make(0);
  994.     else {
  995.     must_be_string(obj, 0);
  996.     return WLNumber_make(strlen(((WOOL_String) obj) -> string));
  997.     }
  998. }
  999.  
  1000. /*
  1001.  * BEWARE: hacker's corner!
  1002.  * returns the object of the same type found at location number!
  1003.  *     type        action
  1004.  *     number        *int
  1005.  *     string        *char
  1006.  *     ()        object
  1007.  *     atom        adress of pointer object
  1008.  */
  1009.  
  1010. WOOL_OBJECT
  1011. wool_hack(type, pointer)
  1012. WOOL_OBJECT type;
  1013. WOOL_Number pointer;
  1014. {
  1015.     if (type -> type == WLNumber)
  1016.     return (WOOL_OBJECT) WLNumber_make(*((int *) pointer -> number));
  1017.     else if (type -> type == WLString)
  1018.     return (WOOL_OBJECT) WLString_make(pointer -> number);
  1019.     else if (type == NIL) {
  1020.     increase_reference(pointer -> number);
  1021.     return (WOOL_OBJECT) pointer -> number;
  1022.     } else if (type -> type == WLAtom)
  1023.     return (WOOL_OBJECT) WLNumber_make(pointer);
  1024.     else
  1025.     return NIL;
  1026. }
  1027.  
  1028. /* used time function expressed in milliseconds
  1029.  */
  1030.  
  1031. #ifdef CLK_TCK
  1032. #define TIME_UNIT CLK_TCK
  1033. #else
  1034. #define TIME_UNIT 60
  1035. #endif
  1036.  
  1037. WOOL_OBJECT
  1038. wool_used_time()
  1039. {
  1040.     long time;
  1041.  
  1042. #ifdef SYSV
  1043.     struct tms buffer;
  1044.  
  1045. #ifdef CLK_TCK
  1046.     time = (times(&buffer) * 1000) / TIME_UNIT;
  1047. #else
  1048.     times(&buffer);
  1049.     time = ((buffer.tms_utime + buffer.tms_stime) * 1000 ) / TIME_UNIT;
  1050. #endif
  1051. #else /* SYSV */
  1052.     struct timeb time_bsd;
  1053.  
  1054.     ftime(&time_bsd);
  1055.     time = 1000 * time_bsd.time + time_bsd.millitm;
  1056. #endif /* SYSV */
  1057.  
  1058.     return (WOOL_OBJECT) WLNumber_make(time);
  1059. }
  1060.  
  1061. /*
  1062.  * atoi and itoa
  1063.  */
  1064.  
  1065. WOOL_OBJECT
  1066. wool_atoi(obj)
  1067. WOOL_String obj;
  1068. {
  1069.     must_be_string(obj, 0);
  1070.     return (WOOL_OBJECT) WLNumber_make(atoi(obj -> string));
  1071. }
  1072.  
  1073. WOOL_OBJECT
  1074. wool_itoa(obj)
  1075. WOOL_Number obj;
  1076. {
  1077.     char tmp_str[20];
  1078.  
  1079.     must_be_number(obj, 0);
  1080.     sprintf(tmp_str, "%d", obj -> number);
  1081.     return (WOOL_OBJECT) WLString_make(tmp_str);
  1082. }
  1083.  
  1084. /*
  1085.  * Shell escape: executes a SYSTEM of the string (or atom) argument
  1086.  */
  1087.  
  1088. WOOL_OBJECT
  1089. shell(argc, argv)
  1090. int        argc;
  1091. WOOL_String     argv[];
  1092. {
  1093.     int             i;
  1094.     char          **program_args = (char **) Malloc(sizeof(char *) * (argc + 1));
  1095.  
  1096.     if (!argc)
  1097.     wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
  1098.     for (i = 0; i < argc; i++) {
  1099.     must_be_string(argv[i], i);
  1100.     program_args[i] = argv[i] -> string;
  1101.     }
  1102.     program_args[argc] = NULL;
  1103.     if (!fork()) {
  1104.     wool_clean_before_exec();
  1105.     execvp(program_args[0], program_args);
  1106.     exit(127);
  1107.     }
  1108.     Free(program_args);
  1109.     return NIL;
  1110. }
  1111.  
  1112. /* signals management avoiding defunct processes */
  1113.  
  1114. #if defined SYSV || defined SVR4
  1115. void
  1116. ChildDeathHandler(sig)
  1117. int sig;
  1118. {
  1119.     wait(0);
  1120.     signal(SIGCLD, ChildDeathHandler);
  1121. }
  1122.  
  1123. SignalsInit()
  1124. {
  1125.     signal(SIGCLD, ChildDeathHandler);
  1126. }
  1127. #else /* SYSV */
  1128. #include <sys/time.h>
  1129. #include <sys/resource.h>
  1130. void
  1131. ChildDeathHandler(sig)
  1132. int sig;
  1133. {
  1134.     union wait status;
  1135.  
  1136.     wait3(&status, WNOHANG, 0);
  1137.     signal(SIGCHLD, ChildDeathHandler);
  1138. }
  1139.  
  1140. SignalsInit()
  1141. {
  1142.     signal(SIGCHLD, ChildDeathHandler);
  1143. }
  1144. #endif /* SYSV */
  1145.  
  1146. /*
  1147.  *  print value of an object
  1148.  */
  1149.  
  1150. WOOL_OBJECT
  1151. wool_print(obj)
  1152. WOOL_OBJECT     obj;
  1153. {
  1154.     wool_print_level = 0;
  1155.     return WOOL_send(WOOL_print, obj, (obj));
  1156. }
  1157.  
  1158. WOOL_OBJECT
  1159. wool_print_nary(argc, argv)
  1160. int argc;
  1161. WOOL_OBJECT     argv[];
  1162. {
  1163.     int             i;
  1164.     WOOL_OBJECT    result = NIL;
  1165.  
  1166.     wool_print_level = 0;
  1167.     for (i = 0; i < argc; i++)
  1168.     result = WOOL_send(WOOL_print, argv[i], (argv[i]));
  1169.     yyoutflush();
  1170.     return result;
  1171. }
  1172.  
  1173. /*XXX-UWE-XXX*/
  1174. static int expand_string_stream ();
  1175.  
  1176. WOOL_OBJECT
  1177. wool_with_output_to_string (argc, argv)
  1178.   int argc;
  1179.   WOOL_OBJECT *argv;
  1180. {
  1181.     WOOL_STRING_STREAM str, WOOL_STRING_STREAM_make (); 
  1182.     int old_type;
  1183.     char *old_stream;
  1184.     WOOL_OBJECT result;
  1185.  
  1186.     str = WOOL_STRING_STREAM_make (256, expand_string_stream);
  1187.     old_type = wool_output_redirect (1, str, &old_stream);
  1188.     progn (argc, argv);
  1189.     wool_output_redirect (old_type, old_stream, NULL);
  1190.  
  1191.     result = (WOOL_OBJECT) WLString_make (str->buffer);
  1192.     WOOL_STRING_STREAM_free (str);
  1193.     return result;
  1194. }
  1195.  
  1196. static int
  1197. expand_string_stream (str)
  1198.   WOOL_STRING_STREAM str;
  1199. {
  1200.     char *new_buf;
  1201.     int nbytes = str->last - str->buffer + 1;
  1202.     int ptr_pos = str->ptr - str->buffer;
  1203.  
  1204.     str->buffer = Realloc (str->buffer, 2*nbytes);        
  1205.     str->last = str->buffer + nbytes - 1;
  1206.     str->ptr = str->buffer + ptr_pos;
  1207. }
  1208. /*XXX-UWE-XXX*/
  1209. /*
  1210.  * (progn inst1 ... instn)
  1211.  * evals the n instructions then return the last one's result
  1212.  */
  1213.  
  1214. WOOL_OBJECT
  1215. progn(argc, argv)
  1216. int    argc;
  1217. WOOL_OBJECT *argv;
  1218. {
  1219.     if (argc) {
  1220.     int             local_zrt_size = zrt_size;
  1221.  
  1222.     while (--argc > 0) {
  1223.         WOOL_send(WOOL_eval, *argv, (*argv));
  1224.         zrt_gc(local_zrt_size);
  1225.         argv++;
  1226.     }
  1227.     return WOOL_send(WOOL_eval, *argv, (*argv));
  1228.     } else {
  1229.     return NIL;
  1230.     }
  1231. }
  1232.  
  1233. /*
  1234.  * if "a la emacs"
  1235.  * if test thenclause [test thenclause]* [elseclause]
  1236.  * nearly a COND, in fact
  1237.  */
  1238.  
  1239. WOOL_OBJECT
  1240. wool_if(argc, argv)
  1241. int    argc;
  1242. WOOL_OBJECT *argv;
  1243. {
  1244.     while (argc > 1) {
  1245.     if (WOOL_send(WOOL_eval, *argv, (*argv)) != NIL) {
  1246.         return WOOL_send(WOOL_eval, *(argv + 1), (*(argv + 1)));
  1247.     }
  1248.     argc -= 2;
  1249.     argv += 2;
  1250.     if (argc == 1) {
  1251.         return WOOL_send(WOOL_eval, *argv, (*argv));
  1252.     }
  1253.     }
  1254.     return NIL;
  1255. }
  1256.  
  1257. /*
  1258.  * while cond inst1 ... instn
  1259.  * classical while
  1260.  */
  1261.  
  1262. WOOL_OBJECT
  1263. wool_while(argc, argv)
  1264. int    argc;
  1265. WOOL_OBJECT *argv;
  1266. {
  1267.     while (WOOL_send(WOOL_eval, *argv, (*argv)) != NIL) {
  1268.     progn(argc - 1, argv + 1);
  1269.     }
  1270.     return NIL;
  1271. }
  1272.  
  1273. /*
  1274.  * for:
  1275.  * (for var list-of-values instructions...)
  1276.  */
  1277.  
  1278. WOOL_OBJECT
  1279. wool_for_loop(argc, argv, map)
  1280. int    argc;
  1281. WOOL_List *argv;
  1282. int        map;
  1283. {
  1284.     WOOL_List       list, result_list;
  1285.     WOOL_OBJECT        /* previous_value, */ result;
  1286.     int i;
  1287.  
  1288.     if (argc < 3)
  1289.     wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
  1290.     must_be_atom(argv[0], 0);
  1291.     list = (WOOL_List) WOOL_send(WOOL_eval, argv[1], (argv[1]));
  1292.     if (WLList_length(list) == 0)  /* (list == (WOOL_List) NIL) */
  1293.         return NIL;
  1294.  
  1295.     WLStackFrame_push_value(argv[0]);
  1296.  
  1297.     if(map) {
  1298.         result_list = wool_list_make(list -> size);
  1299.         for (i = 0; i < list -> size; i++) {
  1300.         WOOL_send(WOOL_setq, argv[0], (argv[0], list -> list[i]));
  1301.         increase_reference(result_list -> list[i] =
  1302.         progn(argc - 2, argv + 2));
  1303.         }
  1304.     } else {
  1305.     for (i = 0; i < list -> size; i++) {
  1306.             WOOL_send(WOOL_setq, argv[0], (argv[0], list -> list[i]));
  1307.             result = progn(argc - 2, argv + 2);
  1308.     }
  1309.     }
  1310.  
  1311.     WLStackFrame_pop();
  1312.  
  1313.     return (map ? (WOOL_OBJECT) result_list : result);
  1314. }
  1315.  
  1316. WOOL_OBJECT
  1317. wool_for(argc, argv)
  1318. int    argc;
  1319. WOOL_List *argv;
  1320. {
  1321.     return wool_for_loop(argc, argv, 0);
  1322. }
  1323.  
  1324. WOOL_OBJECT
  1325. wool_mapfor(argc, argv)
  1326. int    argc;
  1327. WOOL_List *argv;
  1328. {
  1329.     return wool_for_loop(argc, argv, 1);
  1330. }
  1331.  
  1332.  
  1333.  
  1334. /*
  1335.  * TAG/EXIT:
  1336.  * (tag tag insts...)
  1337.  * (exit tag insts...)
  1338.  */
  1339.  
  1340. typedef struct _JumpingPoint {
  1341.     WOOL_StackFrame frame;
  1342.     int         level;         /* in calling_function_stack */
  1343.     jmp_buf        jump_buffer;
  1344. } *JumpingPoint;
  1345.  
  1346. WOOL_OBJECT
  1347. wool_tag(argc, argv)
  1348. int             argc;
  1349. WOOL_String    *argv;
  1350. {
  1351.     struct _JumpingPoint tag;
  1352.     WOOL_OBJECT     result;
  1353.     WOOL_Pointer    tag_name;
  1354.  
  1355.     if (argc < 2)
  1356.     wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
  1357.     must_be_string(argv[0], 0);
  1358.     wool_self_pointer_make(argv[0] -> string, '\024', &tag_name);
  1359.     *(tag_name -> ptr) = (long) &tag;
  1360.     tag.frame = wool_current_stackframe;
  1361.     tag.level = calling_function_current - calling_function_stack;
  1362.     if (!(result = (WOOL_OBJECT) setjmp(tag.jump_buffer))) {
  1363.     result = progn(argc - 1, argv + 1);    /* initialize tag */
  1364.     }
  1365.     *(tag_name -> ptr) = 0;
  1366.     return result;
  1367. }
  1368.     
  1369. WOOL_OBJECT
  1370. wool_exit(argc, argv)
  1371. int             argc;
  1372. WOOL_String    *argv;
  1373. {
  1374.     JumpingPoint    tag;
  1375.     WOOL_Pointer    tag_name;
  1376.     WOOL_OBJECT     result;
  1377.  
  1378.     if (argc < 1)
  1379.     wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
  1380.     must_be_string(argv[0], 0);
  1381.     if (wool_self_pointer_make(argv[0] -> string, '\024', &tag_name)
  1382.     && *(tag_name -> ptr)) {
  1383.     tag = (JumpingPoint) * (tag_name -> ptr);
  1384.     result = argc > 1 ? progn(argc - 1, argv + 1) : NIL;
  1385.     WLStackFrame_pop_to(tag -> frame);
  1386.     calling_function_current = calling_function_stack + tag -> level;
  1387.     longjmp(tag -> jump_buffer, (int)result);
  1388.     } else
  1389.     wool_error(UNDEFINED_VARIABLE, argv[0] -> string);
  1390.     return NIL;
  1391. }
  1392.  
  1393. /* the host name as a string
  1394.  */
  1395.  
  1396. WOOL_OBJECT
  1397. wool_hostname_get()
  1398. {
  1399.     if (!wool_host_name) {
  1400.     char buf[256];
  1401.     int maxlen = 256;
  1402.     int len;
  1403. #ifdef SYSV
  1404.     struct utsname name;
  1405.     
  1406.     uname (&name);
  1407.     len = strlen (name.nodename);
  1408.     if (len >= maxlen) len = maxlen - 1;
  1409.     strncpy (buf, name.nodename, len);
  1410.     buf[len] = '\0';
  1411. #else /* SYSV */
  1412.     buf[0] = '\0';
  1413.     (void) gethostname (buf, maxlen);
  1414.     buf [maxlen - 1] = '\0';
  1415.     len = strlen(buf);
  1416. #endif /* SYSV */
  1417.     increase_reference(wool_host_name = (WOOL_OBJECT) WLString_make(buf));
  1418.     }
  1419.     return  wool_host_name;
  1420. }
  1421.  
  1422. /*
  1423.  * very useful: de and df!
  1424.  * USAGE:
  1425.  * (de <func-name> (parameter-list) inst1 ... instn)
  1426.  * returns  the atom pointing to the subr
  1427.  */
  1428.  
  1429. WOOL_OBJECT
  1430. de(argc, argv)
  1431. int             argc;
  1432. WOOL_OBJECT    *argv;
  1433. {
  1434.     return defun(WLExpr, argc, argv);
  1435. }
  1436.  
  1437. WOOL_OBJECT
  1438. df(argc, argv)
  1439. int             argc;
  1440. WOOL_OBJECT    *argv;
  1441. {
  1442.     return defun(WLFExpr, argc, argv);
  1443. }
  1444.  
  1445. /*
  1446.  * wool_loadfile:
  1447.  * raw loadfile function: search EXACTLY for name in parameter
  1448.  */
  1449.  
  1450. WOOL_OBJECT
  1451. wool_loadfile(string)
  1452. char           *string;
  1453. {
  1454.     FILE           *fd, *oldinput;
  1455.     char            filename[MAX_TEMP_STRING_SIZE];
  1456.     int             local_zrt_size = zrt_size;
  1457.  
  1458.     if (!string)
  1459.     return NIL;
  1460.     strcpy(filename, string);
  1461.     fd = fopen(filename, "r");
  1462.     if (fd) {
  1463.     int             we_got_an_error = 0;
  1464.     char           *old_file = wool_is_reading_file;
  1465.     char            old_input_buffer[AHEAD_BUF_SIZE];
  1466.     int             oldtype = wool_input_redirect(0, fd, &oldinput,
  1467.                               old_input_buffer);
  1468.     int             old_yylineno = yylineno;
  1469.  
  1470.     save_wool_error_resume_point();    /* contains decls */
  1471.     yylineno = 1;
  1472.     wool_is_reading_file = filename;
  1473.     /* now, we must close the file and redirect input on error */
  1474.     if (wool_continue_reading_on_error) {
  1475.         set_wool_error_resume_point();
  1476.         while (wool_read()) {
  1477.         wool_eval(wool_read_expr);
  1478.         zrt_gc(local_zrt_size);
  1479.         }
  1480.     } else {
  1481.         if (set_wool_error_resume_point()) {
  1482.         we_got_an_error = 1;
  1483.         } else {
  1484.         while (wool_read()) {
  1485. #ifdef READ_ECHO
  1486.             printf("\"%s\"[%d]: ", filename, yylineno);
  1487.             wool_print(wool_read_expr);
  1488.             wool_puts("\n");
  1489.             fflush(stdout);
  1490.             fflush(stderr);
  1491. #endif
  1492.             wool_eval(wool_read_expr);
  1493.             zrt_gc(local_zrt_size);
  1494.         }
  1495.         }
  1496.     }
  1497.     wool_input_redirect(oldtype, oldinput, 0, 0);
  1498.     wool_unput(old_input_buffer);
  1499.     fclose(fd);
  1500.     restore_wool_error_resume_point();
  1501.     wool_is_reading_file = old_file;
  1502.     yylineno = old_yylineno;
  1503.     if (we_got_an_error)
  1504.         _wool_error(SILENT_ERROR, 0);
  1505.     return TRU;
  1506.     } else {
  1507.     return NIL;
  1508.     }
  1509. }
  1510.  
  1511. /* executes a given string */
  1512.  
  1513. WOOL_OBJECT
  1514. wool_execute_string(string)
  1515. char           *string;
  1516. {
  1517.     FILE           *oldinput;
  1518.     int             we_got_an_error = 0;
  1519.     char           *old_file = wool_is_reading_file;
  1520.     char            old_input_buffer[AHEAD_BUF_SIZE];
  1521.     int             oldtype = wool_input_redirect(1, string, &oldinput,
  1522.                           old_input_buffer);
  1523.     int             old_yylineno = yylineno;
  1524.     int             local_zrt_size = zrt_size;
  1525.  
  1526.     save_wool_error_resume_point();
  1527.     yylineno = 1;
  1528.     wool_is_reading_file = 0;
  1529.     /* now, we redirect input on error */
  1530.     if (set_wool_error_resume_point()) {
  1531.     we_got_an_error = 1;
  1532.     } else {
  1533.     while (wool_read()) {
  1534.         wool_eval(wool_read_expr);
  1535.         zrt_gc(local_zrt_size);
  1536.     }
  1537.     }
  1538.     wool_input_redirect(oldtype, oldinput, 0, 0);
  1539.     wool_unput(old_input_buffer);
  1540.     restore_wool_error_resume_point();
  1541.     wool_is_reading_file = old_file;
  1542.     yylineno = old_yylineno;
  1543.     if (we_got_an_error)
  1544.     return NIL;
  1545.     else
  1546.     return TRU;
  1547. }
  1548.  
  1549. /* same callable from wool */
  1550.  
  1551. WOOL_OBJECT
  1552. wool_execute_wool_string(string)
  1553. WOOL_String string;
  1554. {
  1555.     return wool_execute_string(string -> string);
  1556. }
  1557.  
  1558. /*
  1559.  * tests if file exists and is readable
  1560.  */
  1561.  
  1562. char *
  1563. file_exists(name)
  1564. char *name;
  1565. {
  1566.     /* Should detect if the file is a regular file, not a directory */
  1567.     struct stat sbuf;
  1568.  
  1569.     if ((stat(name, &sbuf)) < 0)
  1570.     return 0;
  1571.     if ((sbuf.st_mode & S_IFMT) == S_IFREG) {    /* regular file */
  1572.     if (access(name, R_OK)) {    /* good mode flags */
  1573.         return 0;
  1574.     } else
  1575.         return name;
  1576.     } else
  1577.     return 0;
  1578. }
  1579.  
  1580. /*
  1581.  * file_with_optional_extension:
  1582.  * see if file exists with extension
  1583.  */
  1584.  
  1585. char *
  1586. file_with_optional_extension(filename, extension)
  1587. char           *filename;
  1588. char           *extension;
  1589. {
  1590.     static char     filename_wl[MAX_TEMP_STRING_SIZE];
  1591.  
  1592.     strcpy(filename_wl, filename);
  1593.     strcat(filename_wl, extension);
  1594.     if(file_exists(filename_wl))
  1595.         return filename_wl;
  1596.     return file_exists(filename);
  1597. }
  1598.  
  1599. /*
  1600.  * file_in_path:
  1601.  * find file with using path, extensions, etc...
  1602.  * complete_filename is a pointer to temporary space
  1603.  */
  1604.  
  1605. char *
  1606. file_in_path(filename, extension, path, complete_filename)
  1607. char           *filename, *extension, *path, *complete_filename;
  1608. {
  1609.     char  *directory, *name;
  1610.     int         dirlen;
  1611.  
  1612.     if (strchr(filename, '/')) {    /* absolute pathname */
  1613.     return (file_with_optional_extension(filename, extension));
  1614.     } else {            /* relative pathname */
  1615.     while (*path) {
  1616.         directory = path;
  1617.         dirlen = 0;
  1618.         while (*path && (*path != ':')) {
  1619.         path++;
  1620.         dirlen++;
  1621.         }
  1622.         if (*path)
  1623.         path++;
  1624.         complete_filename[dirlen] = '\0';
  1625.         if (dirlen) {
  1626.         strncpy(complete_filename, directory, dirlen);
  1627.         if (complete_filename[dirlen - 1] != '/')
  1628.             strcat(complete_filename, "/");
  1629.         }
  1630.         strcat(complete_filename, filename);
  1631.         if (name = file_with_optional_extension(complete_filename,
  1632.                             extension))
  1633.         return name;
  1634.     }
  1635.     return 0;
  1636.     }
  1637. }
  1638.  
  1639.  
  1640. /*
  1641.  * loading a file (callable from wool)
  1642.  */
  1643.  
  1644. WOOL_OBJECT
  1645. wool_loadfile_in_path(string)
  1646. WOOL_String     string;
  1647. {
  1648.     char            temp_filename[MAX_TEMP_STRING_SIZE];
  1649.     char       *actual_pathname = file_in_path(string -> string,
  1650.                 wool_text_extension, wool_path, temp_filename);
  1651.  
  1652.     if(NIL == wool_loadfile(actual_pathname)) {
  1653.     wool_puts(wool_application_NAME);
  1654.         wool_printf(": file not found: %s\n", string -> string);
  1655.     return NIL;
  1656.     } else {
  1657.         return (WOOL_OBJECT) WLString_make(actual_pathname);
  1658.     }
  1659. }
  1660.  
  1661. /*
  1662.  * cond for compatibility
  1663.  */
  1664.  
  1665. WOOL_OBJECT 
  1666. wool_cond(argc, argv)
  1667. int    argc;
  1668. WOOL_OBJECT *argv;
  1669. {
  1670.     WOOL_OBJECT    *list;
  1671.     WOOL_OBJECT     result = wool_if(argc * 2,
  1672.                   list = wool_flatten_pairlist(argc, argv));
  1673.  
  1674.     Free(list);
  1675.     return result;
  1676. }
  1677.  
  1678. /*
  1679.  * A context is a list of pairs variable-name/variable-values (atom/object).
  1680.  * Context operations are:
  1681.  * 
  1682.  *     context-save: archives in the context the current values of
  1683.  *         variables (sets to () undefined ones...)
  1684.  *     context-restore: sets the variables to their archived values
  1685.  */
  1686.  
  1687. must_be_context(context, n)
  1688. WOOL_List    context;
  1689. int        n;
  1690. {
  1691.     if ((context != (WOOL_List) NIL)
  1692.      && ((context -> type != WLList)
  1693.              || (context -> size % 2)))
  1694.     bad_argument(context, n, "even-sized list");
  1695. }
  1696.  
  1697. WOOL_OBJECT
  1698. wool_context_save(context)
  1699. WOOL_List    context;
  1700. {
  1701.     int             i;
  1702.     WOOL_List       new;
  1703.  
  1704.     must_be_context(context, 0);
  1705.     if (context == (WOOL_List) NIL)
  1706.         return NIL;
  1707.     new = wool_list_make(context -> size);
  1708.     for (i = 0; i < context -> size; i += 2) {
  1709. #ifdef        STUPID
  1710.       WOOL_OBJECT tmp;
  1711. #endif 
  1712.       increase_reference(new -> list[i] = context -> list[i]);
  1713. #ifdef  STUPID
  1714.       tmp = context -> list[i];
  1715.       if (tmp -> type == WLAtom &&
  1716. #else
  1717.       if (context -> list[i] -> type == WLAtom &&
  1718. #endif
  1719.         (!((WOOL_Atom) context -> list[i]) -> c_val)) 
  1720.         /*
  1721.          * if atom is undefined, take the following element of the list
  1722.          * as a value of new context 
  1723.          */
  1724.         increase_reference(new -> list[i + 1] = context -> list[i + 1]);
  1725.     else
  1726.         increase_reference(new -> list[i + 1] =
  1727.         WOOL_send(WOOL_eval, context -> list[i], (context -> list[i])));
  1728.     }
  1729.     return (WOOL_OBJECT) new;
  1730. }
  1731.  
  1732. WOOL_OBJECT
  1733. wool_context_restore(context)
  1734. WOOL_List    context;
  1735. {
  1736.     int             i;
  1737.  
  1738.     must_be_context(context, 0);
  1739.     for (i = 0; i < context -> size; i += 2)
  1740.     WOOL_send(WOOL_setq, context -> list[i],
  1741.           (context -> list[i], context -> list[i + 1]));
  1742.     return (WOOL_OBJECT) context;
  1743. }
  1744.  
  1745. /*
  1746.  * wool_getenv:
  1747.  * makes the WOOL_String out of getenv(wool_string)
  1748.  */
  1749.  
  1750. WOOL_OBJECT
  1751. wool_getenv(obj)
  1752. WOOL_String obj;
  1753. {
  1754.     char  *result;
  1755.  
  1756.     if (result = (char *) getenv(obj -> string))
  1757.     return (WOOL_OBJECT) WLString_make(result);
  1758.     else
  1759.     return (WOOL_OBJECT) NIL_STRING;
  1760. }
  1761.  
  1762. /*
  1763.  * makes an atom out of a string
  1764.  */
  1765.  
  1766. WOOL_OBJECT
  1767. wool_atom_of_string(s)
  1768. WOOL_String    s;
  1769. {
  1770.     return (WOOL_OBJECT) wool_atom(s -> string);
  1771. }
  1772.  
  1773. /*
  1774.  * if object is from type, ok.
  1775.  * if not, evaluates it and call wool_error if result is still not
  1776.  * YOU MUST check reference on result when no longer needed!
  1777.  */
  1778.  
  1779. WOOL_OBJECT
  1780. wool_type_or_evaluate(object, type)
  1781. WOOL_OBJECT object;
  1782. WOOL_TYPE   type;
  1783. {
  1784.     if ((object == NIL) || (object -> type == type))
  1785.     return object;
  1786.     if (((object = WOOL_send(WOOL_eval, object, (object))) -> type == type)
  1787.     || (object == NIL))
  1788.     return object;
  1789.     if (object == UNDEFINED_WOOL_VALUE)
  1790.     return wool_error(UNDEFINED_VARIABLE, "");
  1791.     return bad_argument(object, 0, WOOL_TYPE_P_NAME(type));
  1792. }
  1793.  
  1794. wool_user_end()
  1795. {
  1796.     wool_puts("Bye.\n");
  1797.     wool_end(0);
  1798. }
  1799.  
  1800. #ifdef DEBUG             /* some routines convenient for debugging: */
  1801.  
  1802. stop_if_in_dbx(){} /* used in dbx */
  1803.  
  1804. int        dbxi = 0; 
  1805. WOOL_Atom     dbxa;
  1806. WOOL_OBJECT     dbxo;
  1807.  
  1808. PO(n)
  1809. int n;
  1810. {
  1811.     wool_print(n);
  1812.     wool_newline();
  1813.     fflush(stdout);
  1814. }
  1815.  
  1816. /*
  1817.  * break function for gwm for debugging purposes
  1818.  */
  1819.  
  1820. WOOL_OBJECT
  1821. wool_break(){return NIL;}    /* WOOL user break! */
  1822.  
  1823. WOOL_OBJECT
  1824. wp(obj)
  1825. WOOL_OBJECT     obj;
  1826. {
  1827.     wool_print_level = 0;
  1828.     WOOL_send(WOOL_print, obj, (obj));
  1829.     wool_newline();
  1830.     yyoutflush();
  1831. }
  1832.  
  1833. /*
  1834.  * type(obj) prints its type (under dbx!)
  1835.  */
  1836.  
  1837. wt(obj)
  1838. WOOL_OBJECT obj;
  1839. {
  1840.     printf("%s\n", ((WOOL_Atom) obj -> type[0]) -> p_name);
  1841. }
  1842.  
  1843. char *
  1844. type(obj)
  1845. WOOL_OBJECT obj;
  1846. {
  1847.     return ((WOOL_Atom) obj -> type[0]) -> p_name;
  1848. }
  1849.  
  1850.  
  1851. WOOL_OBJECT
  1852. wool_print_newline(obj)
  1853. WOOL_OBJECT     obj;
  1854. {
  1855.     WOOL_send(WOOL_print, obj, (obj));
  1856.     putchar('\n');
  1857.     return obj;
  1858. }
  1859.  
  1860. struct _UniqId {
  1861.     int size;
  1862.     int last;
  1863.     int *list;
  1864. };
  1865.  
  1866. int
  1867. UniqId(UI, n)
  1868. struct _UniqId *UI;
  1869. int n;
  1870. {
  1871.     int i;
  1872.     if (!UI->size) {
  1873.     UI->size = 4000;
  1874.     UI->list = (int *) Malloc(UI->size);
  1875.     }
  1876.     for (i=0; i< UI->last; i++) {
  1877.     if (UI->list[i] == n) {
  1878.         return i;
  1879.     }
  1880.     }
  1881.     UI->list[i] = n;
  1882.     return (UI->last)++;
  1883. }
  1884.  
  1885. /* checksum on jump-buffers */
  1886.  
  1887. int
  1888. jmpbuf_checksum(jmpbuf)
  1889. int *jmpbuf;
  1890. {
  1891.     int i, result = 0;
  1892.     static struct _UniqId UI;
  1893.     for(i=0; i < sizeof(jmp_buf)/sizeof(int); i++)
  1894.     result = (result << 3) + (result >> 28) + jmpbuf[i];
  1895.     return UniqId(&UI, result);
  1896. }
  1897.  
  1898. #endif /* DEBUG */
  1899.  
  1900. WOOL_OBJECT
  1901. wool_type(obj)
  1902. WOOL_OBJECT obj;
  1903. {
  1904.     return (WOOL_OBJECT) obj->type[0];
  1905. }
  1906.  
  1907. wool_print_type(obj)
  1908. WOOL_OBJECT obj;
  1909. {
  1910.     WLAtom_print(obj -> type[0]);
  1911. }
  1912.  
  1913. #ifdef MONITOR
  1914. WOOL_OBJECT
  1915. wool_moncontrol(num)
  1916. WOOL_Number    num;
  1917. {
  1918.     moncontrol(num ->number);
  1919. }
  1920. #endif /* MONITOR */
  1921.  
  1922. /* tracing info
  1923.  */
  1924.  
  1925. WOOL_OBJECT
  1926. wool_get_trace()
  1927. {
  1928.     return (WOOL_OBJECT) WLNumber_make(wool_tracing_on);
  1929. }
  1930.  
  1931. /* (trace obj)
  1932.  * obj = expr, evals expr at each eval of list
  1933.  * obj = 0/1 turns tracing on/off (without resetting expr)
  1934.  * obj = t resets expr
  1935.  */
  1936.  
  1937. WOOL_OBJECT
  1938. wool_set_trace(obj)
  1939. WOOL_OBJECT obj;
  1940. {
  1941.  
  1942.     if(obj -> type == WLNumber) {
  1943.     wool_tracing_on = ((WOOL_Number) obj) -> number;
  1944.     } else if(obj == NIL) {
  1945.     wool_tracing_on = 0;
  1946.     } else {
  1947.     wool_tracing_on = 1;
  1948.     decrease_reference(wool_tracing_on_EXPR);
  1949.     if (obj == TRU)
  1950.         wool_tracing_on_EXPR = 0;
  1951.     else
  1952.         increase_reference(wool_tracing_on_EXPR = obj);
  1953.     }
  1954.     wool_still_tracing = wool_tracing_on;
  1955.     return obj;
  1956. }
  1957.  
  1958. /***************************************************************************\
  1959. *                                         *
  1960. * add .:$HOME:$HOME/gwm: before built-in-path (INSTALL_DIR) and returns it  *
  1961. * (malloced)                                    *
  1962. *                                         *
  1963. \***************************************************************************/
  1964.  
  1965. char *
  1966. wool_fix_path(built_in_path)
  1967. char *built_in_path;
  1968. {
  1969.     char           *home = (char *) getenv("HOME");
  1970.     char           *path =
  1971.     Malloc(strlen(built_in_path) + 9 + 2*(home ? strlen(home) : 0));
  1972.  
  1973.     strcpy(path, ".:");
  1974.     if (home) {
  1975.     strcat(path, home);
  1976.     strcat(path, ":");
  1977.     strcat(path, home);
  1978.     strcat(path, "/");
  1979.     strcat(path, WOOL_APP_name);
  1980.     strcat(path, ":");
  1981.     }
  1982.     strcat(path, built_in_path);
  1983.     return path;
  1984. }
  1985.  
  1986. /****************************************\
  1987. *                      *
  1988. *  INITIALISATION:             *
  1989. *  to be called before everything else      *
  1990. *                      *
  1991. \****************************************/
  1992.  
  1993. /*
  1994.  * wool_init returns 0 if all is ok
  1995.  * It calls its parameter function if not NULL, just before reading user
  1996.  * profile. Used by GWM for setting default keywords
  1997.  */
  1998.  
  1999. int
  2000. wool_init(client_initialisation)
  2001. int    (*client_initialisation)();
  2002. {
  2003.     /* initialize tables */
  2004.     zrt_init();
  2005.     dft_init();
  2006.     WLNumber_init();
  2007.     HashTable_init();
  2008.  
  2009.     /* initialize signals */
  2010.     SignalsInit();
  2011.  
  2012.     /* initialize wool's objects */
  2013.  
  2014.     wool_atom_make(WOOL_OBJECT, NIL, "()", NIL);    /* atoms */
  2015.     increase_reference(wool_atom("nil") -> c_val = NIL);
  2016.     wool_atom_make(WOOL_OBJECT, TRU, "t", TRU);
  2017.     NIL_STRING_make();
  2018.     WA_progn = (WOOL_OBJECT) wool_atom("progn");
  2019.  
  2020.     /* init stack */
  2021.     WLStackFrame_init();
  2022.     calling_function_init();
  2023.  
  2024.     /* intitialise predefined functions (Subrs) */
  2025.     QUOTE = wool_subr_make(WLFSubr, wool_quote, "quote", 1);
  2026.     wool_subr_make(WLFSubr, setq, "setq", 2);
  2027.     wool_subr_make(WLFSubr, setq, ":", 2);
  2028.     wool_subr_make(WLSubr, set, "set", 2);
  2029.     wool_subr_make(WLSubr, wool_multiply, "*", 2);
  2030.     wool_subr_make(WLSubr, wool_divide, "/", 2);
  2031.     wool_subr_make(WLSubr, wool_modulo, "%", 2);
  2032.     wool_subr_make(WLSubr, wool_add, "+", NARY);
  2033.     wool_subr_make(WLSubr, wool_minus, "-", NARY);
  2034.     increase_reference(wool_atom("defun") -> c_val =
  2035.                wool_subr_make(WLFSubr, de, "de", NARY));
  2036.     increase_reference(wool_atom("defunq") -> c_val =
  2037.                wool_subr_make(WLFSubr, df, "df", NARY));
  2038.     wool_subr_make(WLFSubr, wool_lambda_make, "lambda", NARY);
  2039.     wool_subr_make(WLFSubr, wool_lambdaq_make, "lambdaq", NARY);
  2040.     wool_subr_make(WLSubr, wool_atom_of_string, "atom", 1);
  2041.     wool_subr_make(WLFSubr, progn, "progn", NARY);
  2042.     wool_subr_make(WLFSubr, wool_if, "if", NARY);
  2043.     wool_subr_make(WLFSubr, wool_cond, "cond", NARY);
  2044.     increase_reference(wool_atom("equal") -> c_val =
  2045.                wool_subr_make(WLSubr, wool_equal, "=", 2));
  2046.     wool_subr_make(WLSubr, wool_eq, "eq", 2);
  2047.     wool_subr_make(WLSubr, greater_than, ">", 2);
  2048.     wool_subr_make(WLSubr, lesser_than, "<", 2);
  2049.     wool_subr_make(WLSubr, wool_compare, "compare", 2);
  2050.     wool_subr_make(WLSubr, shell, "!", NARY);
  2051.     increase_reference(wool_atom("print") -> c_val =
  2052.                wool_subr_make(WLSubr, wool_print_nary, "?", NARY));
  2053. /*XXX-UWE-XXX*/
  2054.     wool_subr_make(WLFSubr, wool_with_output_to_string,
  2055.                    "with-output-to-string", NARY);
  2056. /*XXX-UWE-XXX*/
  2057.     wool_subr_make(WLSubr, not, "not", 1);
  2058.     wool_subr_make(WLFSubr, and, "and", NARY);
  2059.     wool_subr_make(WLFSubr, or, "or", NARY);
  2060.     increase_reference(wool_atom("together") -> c_val =
  2061.            wool_subr_make(WLSubr, wool_bitwise_or, "bitwise-or", NARY));
  2062.     wool_subr_make(WLSubr, wool_bitwise_and, "bitwise-and", NARY);
  2063.     wool_subr_make(WLSubr, wool_bitwise_xor, "bitwise-xor", NARY);
  2064.     wool_subr_make(WLFSubr, wool_while, "while", NARY);
  2065.     wool_subr_make(WLFSubr, wool_for, "for", NARY);
  2066.     wool_subr_make(WLFSubr, wool_mapfor, "mapfor", NARY);
  2067.     wool_subr_make(WLFSubr, wool_with, "with", NARY);
  2068.     wool_subr_make(WLFSubr, wool_with_eval, "with-eval", NARY);
  2069.     wool_subr_make(WLSubr, wool_context_save, "context-save", 1);
  2070.     wool_subr_make(WLSubr, wool_context_restore, "context-restore", 1);
  2071.     wool_subr_make(WLSubr, wool_loadfile_in_path, "load", 1);
  2072.     wool_subr_make(WLSubr, wool_execute_wool_string, "execute-string", 1);
  2073.     wool_subr_make(WLSubr, eval, "eval", 1);
  2074.     wool_subr_make(WLSubr, wool_getenv, "getenv", 1);
  2075.     wool_subr_make(WLSubr, wool_unbind, "unbind", 1);
  2076.     wool_subr_make(WLSubr, wool_boundp, "boundp", 1);
  2077.     wool_subr_make(WLSubr, WLString_match, "match", NARY);
  2078.     wool_subr_make(WLSubr, wool_length, "length", 1);
  2079.     wool_subr_make(WLSubr, WLList_sub, "sublist", NARY);
  2080.     increase_reference(wool_atom("nth") -> c_val =
  2081.                wool_subr_make(WLSubr, WLList_nth, "#", NARY));
  2082.     increase_reference(wool_atom("replace-nth") -> c_val =
  2083.             wool_subr_make(WLSubr, WLList_replace_nth, "##", NARY));
  2084.     wool_subr_make(WLSubr, WLList_delete_nth, "delete-nth", 2);
  2085.     wool_subr_make(WLFSubr, wool_user_end, "end", 0);
  2086.     wool_subr_make(WLSubr, wool_atoi, "atoi", 1);
  2087.     wool_subr_make(WLSubr, wool_itoa, "itoa", 1);
  2088.     wool_subr_make(WLSubr, wool_hack, "hack", 2);
  2089.     wool_subr_make(WLSubr, wool_list, "list", NARY);
  2090.     wool_subr_make(WLFSubr, wool_tag, "tag", NARY);
  2091.     wool_subr_make(WLFSubr, wool_exit, "exit", NARY);
  2092.     wool_subr_make(WLSubr, wool_type, "type", 1);
  2093.     wool_subr_make(WLFSubr, wool_error_has_occurred, "error-occurred", NARY);
  2094.     wool_subr_make(WLSubr, wool_trigger_error, "trigger-error", NARY);
  2095.     wool_subr_make(WLSubr, wool_copy, "copy", 1);
  2096.     wool_subr_make(WLSubr, wool_used_time, "elapsed-time", 0);
  2097.     wool_subr_make(WLSubr, wool_member, "member", 2);
  2098.     wool_subr_make(WLSubr, WLNamespace_make, "namespace-make", 0);
  2099.     wool_subr_make(WLSubr, WLNamespace_add, "namespace-add", 1);
  2100.     wool_subr_make(WLSubr, WLNamespace_remove, "namespace-remove", 2);
  2101.     wool_subr_make(WLSubr, WLName_add, "defname", NARY);
  2102.     wool_subr_make(WLSubr, WLNamespace_set_current, "namespace", 2);
  2103.     wool_subr_make(WLSubr, WLName_namespace, "namespace-of", 1);
  2104.     wool_subr_make(WLSubr, WLNamespace_size, "namespace-size", 1);
  2105.     wool_subr_make(WLSubr, WLList_qsort, "sort", 2);
  2106.     wool_active_make("hostname", wool_hostname_get, NULL);
  2107.  
  2108.     /* --- */
  2109. #ifdef STATS
  2110.     wool_subr_make(WLFSubr, zrtstats, "gcinfo", 0);
  2111.     wool_subr_make(WLFSubr, wlcfstats, "wlcfinfo", 0);
  2112.     wool_subr_make(WLFSubr, WlMstats, "meminfo", 0);
  2113.     wool_subr_make(WLFSubr, hashstats, "hashinfo", 0);
  2114.     wool_subr_make(WLFSubr, oblist, "oblist", 0);
  2115. #else /* STATS */
  2116.     wool_subr_make(WLFSubr, NIL_FUNC, "gcinfo", 0);
  2117.     wool_subr_make(WLFSubr, NIL_FUNC, "wlcfinfo", 0);
  2118.     wool_subr_make(WLFSubr, NIL_FUNC, "meminfo", 0);
  2119.     wool_subr_make(WLFSubr, NIL_FUNC, "hashinfo", 0);
  2120.     wool_subr_make(WLFSubr, NIL_FUNC, "oblist", 0);
  2121. #endif /* STATS */
  2122. #ifdef DEBUG
  2123.     wool_subr_make(WLFSubr, wool_break, "break", 0);
  2124. #ifdef GWM
  2125.     wool_subr_make(WLSubr, WLFsm_fp, "print-fsm", 1);
  2126.     wool_subr_make(WLSubr, WLState_fp, "print-state", 1);
  2127.     wool_subr_make(WLSubr, WLArc_fp, "print-arc", 1);
  2128. #endif
  2129. #else /* DEBUG */
  2130.     wool_subr_make(WLFSubr, NIL_FUNC, "break", 0);
  2131. #endif /* DEBUG */
  2132. #ifdef MONITOR
  2133.     wool_subr_make(WLSubr, wool_moncontrol, "moncontrol", 1);
  2134. #endif /* MONITOR */
  2135. #ifdef USER_DEBUG
  2136.     wool_active_make("trace", wool_get_trace, wool_set_trace);
  2137.     wool_pointer_make("trace-level", &wool_tracing_level);
  2138. #endif /* USER_DEBUG */
  2139.  
  2140.     wool_pointer_make("print-level", &wool_max_print_level);
  2141.     wool_pointer_make("stack-print-level", &wool_max_stack_print_level);
  2142.  
  2143.     /* here do client inits before the profile is read */
  2144.     if (client_initialisation)
  2145.     (*client_initialisation) ();
  2146.  
  2147.     /* first time, load the user file */
  2148.     wool_error_status = 0;
  2149.     if (!set_wool_error_resume_point()) {
  2150.     zrt_gc(0);
  2151.     if (wool_loadfile_in_path(wool_atom(wool_user_profile_name)) == NIL) {
  2152.         return 1;
  2153.     }
  2154.     }
  2155.     wlcf_flush();
  2156.     wool_error_in_profile = wool_error_status;
  2157.     set_wool_error_resume_point();
  2158.     dft_gc();
  2159.  
  2160.     return 0;
  2161. }
  2162.  
  2163.