home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / wl_func.c < prev    next >
C/C++ Source or Header  |  1995-07-03  |  18KB  |  714 lines
  1. /* Copyright 1989 GROUPE BULL -- See license conditions in file COPYRIGHT
  2.  * Copyright 1989 Massachusetts Institute of Technology
  3.  */
  4. /********************************************\
  5. *                          *
  6. *  WOOL_OBJECT  Subr, FSubr, Expr and FExpr  *
  7. *  BODY                         *
  8. *                          *
  9. \********************************************/
  10.  
  11. #include "EXTERN.h"
  12. #include <stdio.h>
  13. #include "wool.h"
  14. #include "wl_atom.h"
  15. #include "wl_number.h"
  16. #include "wl_list.h"
  17. #include "INTERN.h"
  18. #include "wl_func.h"
  19.  
  20. /* Constructors:
  21.  * For Subr and FSubr: wool_subr_make
  22.  * takes as arguments:
  23.  *  1-  the type (WLSubr or WLFSubr)
  24.  *  2-  the (pointer to) C function associated
  25.  *  3-  the string which will be its WOOL name
  26.  *  4-  the number of arguments: 0,1,2 or NARY
  27.  * Returns the (F)Subr.
  28.  * 
  29.  * For the Expr and FExpr: defun
  30.  * takes as arguments:
  31.  *  1-  the type (WLExpr or WLFExpr)
  32.  *  2-  the argc,
  33.  *  3-  the argv
  34.  *      of the list (funcname (list of args) stat1 stat2 ... statn)
  35.  *      corresponding to the WOOL definition.
  36.  * Returns the (F)Expr.
  37.  */
  38.  
  39. WOOL_OBJECT 
  40. defun(type, argc, argv)
  41. WOOL_TYPE       type;        /* WLExpr or WLFExpr */
  42. int             argc;        /* the list without the "de" or "df" */
  43. WOOL_Atom      *argv;
  44. {
  45.     WOOL_OBJECT func;
  46.  
  47.     if(argc < 2)
  48.         return wool_error(BAD_DEFUN, ((WOOL_Atom) (*(argv))) -> p_name);
  49.     func = wool_lambda_make(argc -1, argv +1);
  50.     func -> type = type;
  51.     return WOOL_send(WOOL_setq, argv[0], (argv[0], func));
  52. }
  53.  
  54. WOOL_OBJECT 
  55. wool_subr_make(type, C_function, wool_name, arity)
  56. WOOL_TYPE       type;
  57. WOOL_OBJECT(*C_function) ();
  58. char           *wool_name;
  59. int             arity;
  60. {
  61.     WOOL_OBJECT     func = (WOOL_OBJECT)
  62.     WLSubr_make(type, C_function, arity);
  63.     WOOL_Atom       object = wool_atom(wool_name);
  64.  
  65.     increase_reference(object -> c_val = func);
  66.     return (WOOL_OBJECT) func;
  67. }
  68.  
  69. /*
  70.  * WLSubr_make:
  71.  * makes a (F)Subr (without knowing its name)
  72.  */
  73.  
  74. WOOL_Subr 
  75. WLSubr_make(type, C_function, arity)
  76. WOOL_TYPE       type;
  77.  
  78. WOOL_OBJECT(*C_function) ();
  79. int             arity;
  80.  
  81. {
  82.     WOOL_Subr       object = (WOOL_Subr) Malloc(sizeof(struct _WOOL_Subr));
  83.  
  84.     object -> type = type;
  85.     zrt_put(object);
  86.     object -> arity = arity;
  87.     object -> body = C_function;
  88.     return object;
  89. }
  90.  
  91. /*
  92.  * the real creator of Exprs, lambda
  93.  */
  94.  
  95. WOOL_OBJECT
  96. wool_lambda_make(argc, argv)
  97. int             argc;           /* the list without the "de" or "df" */
  98. WOOL_OBJECT    *argv;
  99. {
  100.     WOOL_Expr       object;
  101.     int             i;
  102.     WOOL_List       parameters = (WOOL_List) argv[0];
  103.  
  104.     if (argc < 1)
  105.     wool_error(BAD_DEFUN, ((WOOL_Atom) (*(argv))) -> p_name);
  106.     if ((parameters -> type != WLList) && (argv[0] != NIL)) {
  107.     if (parameters -> type == WLAtom) {    /* NARY */
  108.         parameters = (WOOL_List) wool_list(1, &(argv[0]));
  109.     } else
  110.         wool_error(BAD_DEFUN, ((WOOL_Atom) (*(argv))) -> p_name);
  111.     }
  112.     if (parameters != (WOOL_List) NIL) {
  113.     for (i = 0; i < parameters -> size; i++) {
  114. #ifdef    STUPID
  115.         WOOL_OBJECT tmp;
  116.         tmp = parameters -> list[i];
  117.         if (tmp -> type != WLAtom)
  118. #else
  119.         if (parameters -> list[i] -> type != WLAtom)
  120. #endif
  121.         wool_error(NOT_REDEFINABLE, parameters -> list[i]);
  122.     }
  123.     }
  124.     object = (WOOL_Expr) Malloc(sizeof(struct _WOOL_Expr));
  125.     object -> type = WLExpr;
  126.     zrt_put(object);
  127.     if (parameters == (WOOL_List) NIL) {
  128.     object -> arity = 0;
  129.     } else {
  130.     object -> arity = parameters -> size;
  131.     }
  132.     if (object -> arity) {
  133.     duplicate_n_objects(parameters -> list, &(object -> parameters),
  134.                 object -> arity);
  135.     } else {
  136.     object -> parameters = 0;
  137.     }
  138.     if (object -> body_size = argc - 1) {
  139.     duplicate_n_objects(argv + 1, &(object -> body), object -> body_size);
  140.     }
  141.     if (argv[0] -> type == WLAtom && argv[0] != NIL)
  142.         object -> arity = NARY;
  143.     return (WOOL_OBJECT) object;
  144. }
  145.  
  146. WOOL_OBJECT
  147. wool_lambdaq_make(argc, argv)
  148. int             argc;           /* the list without the "de" or "df" */
  149. WOOL_OBJECT    *argv;
  150. {
  151.     WOOL_OBJECT lambda = wool_lambda_make(argc, argv);
  152.     lambda -> type = WLFExpr;
  153.     return lambda;
  154. }
  155.  
  156. /*
  157.  * printing a function is pretty-printing its definition.
  158.  */
  159.  
  160. WOOL_OBJECT 
  161. WLFSubr_print(obj)
  162. WOOL_FSubr      obj;
  163. {
  164.     wool_putchar('F');
  165.     return WLSubr_print(obj);
  166. }
  167.  
  168. WOOL_OBJECT 
  169. WLSubr_print(obj)
  170. WOOL_Subr       obj;
  171. {
  172.     if (obj -> arity == NARY) {
  173.     wool_puts("SUBR n-ary: ");
  174.     } else {
  175.     wool_printf("SUBR with %d parameters: ", obj -> arity);
  176.     }
  177.     print_atom_pointing_to(obj);
  178.     return (WOOL_OBJECT) obj;
  179. }
  180.  
  181. WOOL_OBJECT 
  182. WLExpr_print(obj)
  183. WOOL_Expr       obj;
  184. {
  185.     int             i = 0;
  186.  
  187.     if (obj -> arity == NARY)
  188.     wool_puts("EXPR n-ary: ");
  189.     else
  190.     wool_printf("EXPR with %d parameters: ", obj -> arity);
  191.     print_atom_pointing_to(obj);
  192.     for (; i < (obj -> arity != NARY ? obj -> arity : 1); i++) {
  193.     WOOL_send(WOOL_print, *(obj -> parameters + i),
  194.           (*(obj -> parameters + i)));
  195.     wool_putchar(' ');
  196.     }
  197.     for (i = 0; i < obj -> body_size; i++) {
  198.     printf("\n    ");
  199.     WOOL_send(WOOL_print, *(obj -> body + i), (*(obj -> body + i)));
  200.     }
  201.     return (WOOL_OBJECT) obj;
  202. }
  203.  
  204. WOOL_OBJECT 
  205. WLFExpr_print(obj)
  206. WOOL_FExpr      obj;
  207. {
  208.     wool_putchar('F');
  209.     return (WLExpr_print(obj));
  210. }
  211.  
  212. /*
  213.  * freeing:
  214.  */
  215.  
  216. WOOL_OBJECT 
  217. WLExpr_free(obj)
  218. WOOL_Expr       obj;
  219. {
  220.     if (obj -> body_size) {
  221.     decrease_reference_in_list(obj -> body_size, obj -> body);
  222.     DelayedFree(obj -> body);
  223.     }
  224.     if (obj -> arity) {
  225.     decrease_reference_in_list(obj -> arity, obj -> parameters);
  226.     DelayedFree(obj -> parameters);
  227.     }
  228.     DelayedFree(obj);
  229.     return NULL;
  230. }
  231.  
  232. /*
  233.  * main routines: execution!
  234.  */
  235.  
  236. /*
  237.  * Note: for NARY function, a list of evaluated args is created.
  238.  */
  239.  
  240. WOOL_OBJECT 
  241. WLSubr_execute(obj, list)
  242. WOOL_Subr obj;        /* the function */
  243. WOOL_List       list;
  244. {
  245.     WOOL_OBJECT result;
  246.     int    argc = list -> size - 1;
  247.     WOOL_OBJECT *argv = list -> list + 1;
  248.  
  249.     ASSERT(obj -> body);
  250.     /* NARY FUNCTIONS */
  251.     if (obj -> arity == NARY) {
  252.     if (argc) {
  253.         WOOL_OBJECT    *eval_list =
  254.         (WOOL_OBJECT *) Malloc(sizeof(WOOL_OBJECT) * argc);
  255.  
  256.         result = (*(obj -> body)) (argc,
  257.                        map_eval(argc, argv, eval_list));
  258.         Free(eval_list);
  259.         return result;
  260.     } else {
  261.         return (*(obj -> body)) (0, 0);
  262.     }
  263.     } else {
  264.     /* FIXED ARITY */
  265.     if (obj -> arity != argc) {
  266.         return wool_error(BAD_NUMBER_OF_ARGS, argc);
  267.     } else {
  268.         switch (obj -> arity) {
  269.         case 0:
  270.         return (*(obj -> body)) ();
  271.         case 1:
  272.         return (*(obj -> body)) (
  273.                       WOOL_send(WOOL_eval, *argv, (*argv)));
  274.         case 2:
  275. #ifdef STUPID
  276.         {
  277.             WOOL_OBJECT     arg1 = WOOL_send(WOOL_eval, *argv,
  278.                              (*argv));
  279.             WOOL_OBJECT     arg2 = WOOL_send(WOOL_eval, *(argv + 1),
  280.                              (*(argv + 1)));
  281.  
  282.             return (*(obj -> body)) (arg1, arg2);
  283.         }
  284. #else /* STUPID */
  285.         return (*(obj -> body)) (
  286.                        WOOL_send(WOOL_eval, *argv, (*argv)),
  287.               WOOL_send(WOOL_eval, *(argv + 1), (*(argv + 1))));
  288. #endif /* STUPID */
  289.         default:
  290.         return NIL;    /* should not be reached */
  291.         }
  292.     }
  293.     }
  294. }
  295.  
  296. WOOL_OBJECT 
  297. WLFSubr_execute(obj, list)
  298. WOOL_FSubr obj;    /* the function */
  299. WOOL_List          list;
  300. {
  301.     int    argc = list -> size - 1;
  302.     WOOL_OBJECT *argv = list -> list + 1;
  303.  
  304.     ASSERT(obj->body);
  305.     if (obj -> arity == NARY) {
  306.     return (*(obj -> body)) (argc, argv);
  307.     } else {
  308.     if (obj -> arity != argc) {
  309.         return wool_error(BAD_NUMBER_OF_ARGS, argc);
  310.     } else {
  311.         switch (obj -> arity) {
  312.         case 0:
  313.         return (*(obj -> body)) ();
  314.         case 1:
  315.         return (*(obj -> body)) (*argv);
  316.         case 2:
  317.         return (*(obj -> body)) (*argv, *(argv + 1));
  318.         default:
  319.         return NIL;    /* should not be reached */
  320.         }
  321.     }
  322.     }
  323. }
  324.  
  325. WOOL_OBJECT 
  326. WLExpr_execute(obj, list)
  327. WOOL_Expr obj;
  328. WOOL_List          list;
  329. {
  330.     int    argc = list -> size - 1;
  331.     WOOL_OBJECT *argv = list -> list + 1;
  332.  
  333.     if (obj -> arity != NARY) {
  334.     if (!argc) {
  335.         return execute_local_code(0, 0, 0, 0,
  336.                       obj -> body_size, obj -> body);
  337.     } else {
  338.         WOOL_OBJECT result, *local_list;
  339.  
  340.         local_list = (WOOL_OBJECT *)
  341.         Malloc(sizeof(WOOL_OBJECT) * argc);
  342.         map_eval(argc, argv, local_list);
  343.         result = execute_local_code(argc, local_list,
  344.                     obj -> arity, obj -> parameters,
  345.                     obj -> body_size, obj -> body);
  346.         Free(local_list);
  347.         return (result);
  348.     }
  349.     } else {
  350.     if (!argc) {
  351.         return execute_local_code(1, &NIL, 1, obj -> parameters,
  352.                       obj -> body_size, obj -> body);
  353.     } else {
  354.         WOOL_List       parameters_list = (WOOL_List)
  355.         wool_list_make_from_evaluated_array(argc, argv);
  356.  
  357.         return execute_local_code(1, ¶meters_list, 1,
  358.               obj -> parameters, obj -> body_size, obj -> body);
  359.     }
  360.     }
  361. }
  362.  
  363. WOOL_OBJECT 
  364. WLFExpr_execute(obj, list)
  365. WOOL_FExpr obj;
  366. WOOL_List          list;
  367. {
  368.     if (obj -> arity != NARY) {
  369.     return execute_local_code(list -> size - 1, list -> list + 1,
  370.                   obj -> arity, obj -> parameters,
  371.                   obj -> body_size, obj -> body);
  372.     } else {
  373.     if (!(list -> size - 1)) {
  374.         return execute_local_code(1, &NIL, 1, obj -> parameters,
  375.                       obj -> body_size, obj -> body);
  376.     } else {
  377.         WOOL_List       parameters_list = (WOOL_List)
  378.         wool_list(list -> size - 1, list -> list + 1);
  379.  
  380.         return execute_local_code(1, ¶meters_list, 1,
  381.               obj -> parameters, obj -> body_size, obj -> body);
  382.     }
  383.     }
  384.  
  385. }
  386.  
  387. /***********************************************\
  388. *                             *
  389. *  Accessory functions for evaluation purposes  *
  390. *                             *
  391. \***********************************************/
  392.  
  393. /*
  394.  * here goes all the stuff really needed to operate the evaluation
  395.  * mecanism of WOOL.
  396.  */
  397.  
  398. /*
  399.  *  map_eval evaluates "a la APL"
  400.  */
  401.  
  402. WOOL_OBJECT    *
  403. map_eval(size, source, dest)
  404. int    size;
  405. WOOL_OBJECT *source, *dest;
  406. {
  407.     WOOL_OBJECT *last = source + size;
  408.  
  409.     while (source < last) {
  410.     *dest = WOOL_send(WOOL_eval, *source, (*source));
  411.     dest++, source++;
  412.     }
  413.     return dest - size;
  414. }
  415.  
  416. /* 
  417.  * execute_local_code:
  418.  * main program for all function calls.
  419.  * (note: values = NULL ==> alls params set to NIL) (handy hack)
  420.  * Values will be check_referenced
  421.  */
  422.  
  423. WOOL_OBJECT 
  424. execute_local_code(values_size, values,
  425.            parameters_size, parameters,
  426.            body_size, body)
  427. int             values_size, parameters_size, body_size;
  428. WOOL_OBJECT *values, *parameters, *body;
  429. {
  430.     WOOL_OBJECT     result;
  431.  
  432.     if (values_size != parameters_size)
  433.     wool_error(BAD_NUMBER_OF_ARGS, values_size);
  434.     if (parameters_size) {
  435.     WLStackFrame_push(parameters_size, parameters, values);
  436.     result = (WOOL_OBJECT) progn(body_size, body);
  437.     WLStackFrame_pop_for_function_calls();
  438.     return result;
  439.     } else {
  440.     return (WOOL_OBJECT) progn(body_size, body);
  441.     }
  442. }
  443.  
  444. /*****************************\
  445. *                   *
  446. * Local variables management  *
  447. *                   *
  448. \*****************************/
  449.  
  450. /*
  451.  * the simpler local variable declarations "WITH"
  452.  * used as in (with (x 1 y 2) ...insts...)
  453.  */
  454.  
  455. WOOL_OBJECT 
  456. wool_with(argc, argv)
  457. int    argc;
  458. WOOL_OBJECT *argv;
  459. {
  460.     WOOL_OBJECT     result;
  461.     WOOL_List       vars = (WOOL_List) argv[0];
  462.  
  463.     if ((argc < 2) || (vars -> size % 2 && vars -> size > 2))
  464.     return wool_error(BAD_LOCAL_SYNTAX, "");
  465.     if (((vars -> type != WLList) && (vars != (WOOL_List) NIL))
  466.     || (vars -> size % 2)) {
  467.     vars = (WOOL_List) WOOL_send(WOOL_eval, vars, (vars));
  468.     must_be_context(vars, 0);
  469.     }
  470.     if (vars == (WOOL_List) NIL) {
  471.     return (WOOL_OBJECT) progn(argc - 1, argv + 1);
  472.     }
  473.  
  474.     WLStackFrame_push_spaced_values(vars -> size / 2, vars->list);
  475.     result = (WOOL_OBJECT) progn(argc - 1, argv + 1);
  476.     WLStackFrame_pop();
  477.     return result;
  478. }
  479.  
  480. /*
  481.  * with_eval evaluates first its first argument    before calling wool_with
  482.  */
  483.  
  484. WOOL_OBJECT
  485. wool_with_eval(argc, argv)
  486. int    argc;
  487. WOOL_OBJECT *argv;
  488. {
  489.     WOOL_OBJECT    *eval_args, result;
  490.     int i;
  491.  
  492.     if (argc == 0)
  493.     return wool_error(BAD_LOCAL_SYNTAX, "");
  494.     eval_args = (WOOL_OBJECT *) Malloc(sizeof(WOOL_OBJECT) * argc);
  495.     eval_args[0] = WOOL_send(WOOL_eval, argv[0], (argv[0]));
  496.     for (i = 1; i <argc; i++){
  497.     eval_args[i] = argv[i];
  498.     }
  499.     result = wool_with(argc, eval_args);
  500.     Free(eval_args);
  501.     return result;
  502. }
  503.  
  504. /**************************\
  505. *                *
  506. * Stack frames management  *
  507. *                *
  508. \**************************/
  509.  
  510. /* initialize first stack frame */
  511.  
  512. WLStackFrame_init()
  513. {
  514.     wool_first_stackframe.previous = NULL;
  515.     wool_first_stackframe.size = 0;
  516. }
  517.  
  518. /* pushes arguments on stack (functional call) */
  519.  
  520. WLStackFrame_push(size, parameters, new_values)
  521. int         size;
  522. WOOL_Atom      *parameters;
  523. WOOL_OBJECT    *new_values;
  524. {
  525.     WOOL_StackFrame frame = (WOOL_StackFrame) Malloc(
  526.     sizeof(struct _WOOL_StackFrame) + (size - 1) * sizeof(WOOL_OBJECT));
  527.     WOOL_OBJECT    *old_values = frame -> old_values;
  528.     WOOL_Atom      *end_param = parameters + size;
  529.  
  530.     CheckLoopsPush();
  531.     frame -> previous = wool_current_stackframe;
  532.     frame -> size = size;
  533.     frame -> parameters = parameters;
  534.     frame -> new_values = new_values;
  535.  
  536.     while (parameters < end_param) {
  537.     *old_values++ = (*parameters) -> c_val;
  538.     increase_reference((*parameters++) -> c_val = *new_values++);
  539.     }
  540.     wool_current_stackframe = frame;    /* last in case of errors in eval */
  541. }
  542.  
  543. /* pushes arguments on stack (declarative (with) call)
  544.  * parameters and new_values are set to point in the old_value space
  545.  */
  546.  
  547. WLStackFrame_push_spaced_values(size, param_and_values)
  548. int             size;
  549. WOOL_Atom      *param_and_values;
  550. {
  551.     WOOL_StackFrame frame = (WOOL_StackFrame) Malloc(
  552.     sizeof(struct _WOOL_StackFrame) + (size * 3 - 1) * sizeof(WOOL_OBJECT));
  553.     WOOL_OBJECT    *old_values = frame -> old_values;
  554.     WOOL_Atom      *parameters = (WOOL_Atom *) old_values + size;
  555.     WOOL_OBJECT    *new_values = (WOOL_OBJECT *) parameters + size;
  556.     WOOL_Atom      *end_param = (WOOL_Atom *) new_values;
  557.  
  558.     CheckLoopsPush();
  559.     frame -> previous = wool_current_stackframe;
  560.     frame -> size = size;
  561.     frame -> parameters = parameters;
  562.     frame -> new_values = new_values;
  563.  
  564.     while (parameters < end_param) {
  565.     *parameters = *param_and_values++;
  566.     *old_values =
  567.         WOOL_send(WOOL_silent_eval, *parameters, (*parameters));
  568.     if (*old_values) increase_reference (*old_values);
  569.     *new_values = WOOL_send(WOOL_eval,
  570.                 *param_and_values, (*param_and_values));
  571.     WOOL_send(WOOL_setq, *parameters, (*parameters, *new_values));
  572.     old_values++;
  573.     new_values++;
  574.     param_and_values++;
  575.     parameters++;
  576.     }
  577.     wool_current_stackframe = frame;    /* last in case of errors in eval */
  578. }
  579.  
  580. /* pushes one value on stack without affecting it
  581.  */
  582.  
  583. WLStackFrame_push_value(variable)
  584. WOOL_Atom       variable;
  585. {
  586.     WOOL_StackFrame frame = (WOOL_StackFrame)
  587.     Malloc(sizeof(struct _WOOL_StackFrame) +
  588.            (1 * 3 - 1) * sizeof(WOOL_OBJECT));
  589.     WOOL_OBJECT    *old_values = frame -> old_values;
  590.     WOOL_Atom      *parameters = (WOOL_Atom *) old_values + 1;
  591.     WOOL_OBJECT    *new_values = (WOOL_OBJECT *) parameters + 1;
  592.     WOOL_Atom      *end_param = (WOOL_Atom *) new_values;
  593.  
  594.     CheckLoopsPush();
  595.     frame -> previous = wool_current_stackframe;
  596.     frame -> size = 1;
  597.     frame -> parameters = parameters;
  598.     frame -> new_values = new_values;
  599.  
  600.     *parameters = variable;
  601.     *old_values =
  602.     WOOL_send(WOOL_silent_eval, *parameters, (*parameters));
  603.     if (*old_values) increase_reference (*old_values);
  604.     wool_current_stackframe = frame; /* last in case of errors in eval */
  605. }
  606.  
  607. /* restores old parameters values and de-pop frame stack */
  608.  
  609. WLStackFrame_pop()
  610. {
  611.     WOOL_Atom      *parameters = wool_current_stackframe -> parameters;
  612.     WOOL_OBJECT    *old_values = wool_current_stackframe -> old_values;
  613.     WOOL_Atom      *param = parameters + wool_current_stackframe -> size;
  614.     WOOL_OBJECT    *old_value = old_values + wool_current_stackframe -> size;
  615.     WOOL_StackFrame previous_frame = wool_current_stackframe -> previous;
  616.  
  617.     CheckLoopsPop();
  618.     while (param > parameters) {
  619.     param--, old_value--;
  620.     if (*old_value) {
  621.         WOOL_send(WOOL_setq, *param, (*param, *old_value));
  622.         decrease_reference(*old_value);
  623.     } else {
  624.         decrease_reference((*param) -> c_val);
  625.         (*param) -> c_val = 0;
  626.     }
  627.     }
  628.     Free(wool_current_stackframe);
  629.     wool_current_stackframe = previous_frame;
  630. }
  631.  
  632. /* special version for functions (only atoms there) */
  633.  
  634. WLStackFrame_pop_for_function_calls()
  635. {
  636.     WOOL_Atom      *parameters = wool_current_stackframe -> parameters;
  637.     WOOL_OBJECT    *old_values = wool_current_stackframe -> old_values;
  638.     WOOL_Atom      *param = parameters + wool_current_stackframe -> size;
  639.     WOOL_OBJECT    *old_value = old_values + wool_current_stackframe -> size;
  640.     WOOL_StackFrame previous_frame = wool_current_stackframe -> previous;
  641.  
  642.     CheckLoopsPop();
  643.     while (param > parameters) { 
  644.     param--, old_value--; 
  645.     decrease_reference((*param) -> c_val); 
  646.     (*param) -> c_val = *old_value; 
  647.     } 
  648.     Free(wool_current_stackframe);
  649.     wool_current_stackframe = previous_frame;
  650. }
  651.  
  652. /* pop all the frames from current to given one */
  653.  
  654. WLStackFrame_pop_to(to_frame)
  655. WOOL_StackFrame to_frame;
  656. {
  657.     while (wool_current_stackframe != to_frame) {
  658.     ASSERT(wool_current_stackframe -> previous);
  659.     WLStackFrame_pop();
  660.     }
  661. }
  662.  
  663. /**************\
  664. *            *
  665. *  stack dump  *
  666. *            *
  667. \**************/
  668.  
  669. #define calling_function_initial_size 63
  670.  
  671. calling_function_init()
  672. {
  673.     calling_function_stack = (WOOL_OBJECT *) Malloc(sizeof(WOOL_OBJECT) *
  674.                          calling_function_initial_size);
  675.     calling_function_end = calling_function_stack
  676.     + calling_function_initial_size;
  677.     calling_function_current = calling_function_stack;
  678. }
  679.  
  680. /* prints the calling function */
  681.  
  682. wool_stack_dump(where)
  683. int where;                /* 0 normal, 1 stderr */
  684. {
  685.     int level = calling_function_current - calling_function_stack;
  686.     int last_printed = Max(0, level - wool_max_stack_print_level);
  687.  
  688.     if (wool_max_stack_print_level < 0)
  689.     last_printed = 0;
  690.     while (--level >= last_printed)
  691.     calling_function_print(calling_function_stack[level], where, level);
  692. }
  693.  
  694. /* prints one frame */
  695.  
  696. calling_function_print(calling_list, where, level)
  697. WOOL_List    calling_list;
  698. int where;                              /* 0 normal, 1 stderr */
  699. int level;
  700. {
  701.     if (calling_list && calling_list != (WOOL_List) NIL) {
  702.     if (where) {
  703.         WOOL_Atom       atom = (WOOL_Atom) calling_list -> list[0];
  704.  
  705.         if (atom -> type == WLAtom)
  706.         fprintf(stderr, "In function %s\n", atom -> p_name);
  707.     } else {
  708.         wool_printf("[%d] ", level);
  709.         wool_print(calling_list);
  710.         wool_newline();
  711.     }
  712.     }
  713. }
  714.