home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d3xx / d386 / xlispstat.lha / XLispStat / src2.lzh / XLisp-Stat / basics.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-10-02  |  19.5 KB  |  726 lines
  1. /* basics - Basic functions for manipulating compound data             */
  2. /* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney                  */
  3. /* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz    */
  4. /* You may give out copies of this software; for conditions see the    */
  5. /* file COPYING included with this distribution.                       */
  6.  
  7. #include "xlisp.h"
  8. #include "osdef.h"
  9. #ifdef ANSI
  10. #include "xlproto.h"
  11. #include "xlsproto.h"
  12. #else
  13. #include "xlfun.h"
  14. #include "xlsfun.h"
  15. #endif ANSI
  16. #include "xlsvar.h"
  17.  
  18. #ifdef ANSI
  19. int ordered_nneg_seq(LVAL),allfixargs(void),
  20.     translate_index(int,LVAL,LVAL,LVAL,LVAL,LVAL,LVAL);
  21. void permute_indices(LVAL,LVAL,LVAL,int),indices_from_rowmajor(LVAL,int,LVAL),
  22.      setcons(LVAL,LVAL,LVAL);
  23. #else
  24. int ordered_nneg_seq(),allfixargs(),
  25.     translate_index();
  26. void permute_indices(),indices_from_rowmajor(),setcons();
  27. #endif ANSI
  28.  
  29. /**************************************************************************/
  30. /**                                                                      **/
  31. /**                         Sequence Predicate                           **/
  32. /**                                                                      **/
  33. /**************************************************************************/
  34.  
  35. /* internal sequencep */
  36. /*sequencep(x)          defined as a macro in xlsdef.h JKL
  37.      LVAL x;
  38. {
  39.   return(listp(x) || simplevectorp(x));
  40. }
  41. */
  42. /* Built in SEQUENCEP */
  43. LVAL xssequencep()
  44. {
  45.   LVAL x;
  46.  
  47.   x = xlgetarg();
  48.   xllastarg();
  49.   return((sequencep(x)) ? s_true : NIL);
  50. }
  51.  
  52. /**************************************************************************/
  53. /**                                                                      **/
  54. /**                           Copying Functions                          **/
  55. /**                                                                      **/
  56. /**************************************************************************/
  57.  
  58. /* Built in COPY-VECTOR function */
  59. LVAL xscopyvector()
  60. {
  61.   LVAL v;
  62.   
  63.   v = xlgavector();
  64.   xllastarg();
  65.   
  66.   return(copyvector(v));
  67. }
  68.  
  69. #define copyseq(x) ((vectorp(x)) ? copyvector(x) : copylist(x))
  70.  
  71. /* internal array copying function */
  72. LVAL copyarray(array)
  73.      LVAL array;
  74. {
  75.   LVAL dim, data, result;
  76.   
  77.   if (simplevectorp(array)) result = copyvector(array);
  78.   else if (displacedarrayp(array)) {
  79.   
  80.     /* protext some pointers */
  81.     xlstkcheck(3);
  82.     xlsave(result);
  83.     xlsave(dim);
  84.     xlsave(data);
  85.   
  86.     dim = copyseq(displacedarraydim(array));
  87.     data = copyvector(arraydata(array));
  88.     result = makedisplacedarray(dim, data);
  89.   
  90.     /* restore the stack frame */
  91.     xlpopn(3);
  92.   }
  93.   else xlerror("not an array", array);
  94.   
  95.   return(result);
  96. }
  97.  
  98. LVAL xscopyarray()
  99. {
  100.   LVAL array;
  101.  
  102.   array = xsgetarray();
  103.   xllastarg();
  104.   
  105.   return(copyarray(array));
  106. }
  107.  
  108. /**************************************************************************/
  109. /**                                                                      **/
  110. /**                  Compound Data Decomposition Functions               **/
  111. /**                                                                      **/
  112. /**************************************************************************/
  113.  
  114. /* Built in SPLIT-LIST function */
  115. LVAL xssplitlist()
  116. {
  117.   LVAL data;
  118.   int n;
  119.   
  120.   data = xlgalist();
  121.   n = getfixnum(xlgafixnum());
  122.   xllastarg();
  123.   
  124.   return(splitlist(data, n));
  125. }
  126.  
  127. /**************************************************************************/
  128. /**                                                                      **/
  129. /**                         WHICH Function                               **/
  130. /**                                                                      **/
  131. /**************************************************************************/
  132.  
  133. /* Built in WHICH function. Generates indices in the data sequence of     */
  134. /* a compound data item where argument elements are not nil. Should do    */
  135. /* something more reasonable for non sequence compound data.              */
  136. LVAL xswhich()
  137. {
  138.   LVAL x, result, data, index, tail;
  139.   int i, n;
  140.   
  141.   /* protect the result pointer */
  142.   xlstkcheck(3);
  143.   xlsave(result);
  144.   xlsave(index);
  145.   xlsave(data);
  146.   
  147.   x = xlgetarg();
  148.   xllastarg();
  149.   
  150.   if (compoundp(x)) {
  151.     data = compounddataseq(x);
  152.     n = compounddatalen(x);
  153.     for (i = 0; i < n; i++)
  154.       if (getnextelement(&x, i) != NIL) {
  155.     index = cvfixnum((FIXTYPE) i);
  156.     if (result == NIL) {
  157.       result = consa(index);
  158.       tail = result;
  159.     }
  160.     else {
  161.       rplacd(tail, consa(index));
  162.       tail = cdr(tail);
  163.     }
  164.       }
  165.   }
  166.   else xlbadtype(x);
  167.  
  168.   /* restore the stack frame */
  169.   xlpopn(3);
  170.   
  171.   return(result);
  172. }
  173.  
  174. /**************************************************************************/
  175. /**                                                                      **/
  176. /**                       List Construction Functions                    **/
  177. /**                                                                      **/
  178. /**************************************************************************/
  179.  
  180. /* internal version of ISEQ function */
  181. LVAL iseq(m, n) 
  182.   int m, n;
  183. {
  184.   int length, i;
  185.   LVAL result, next;
  186.  
  187.   /* protect the result pointer */
  188.   xlsave1(result);
  189.   
  190.   length = abs(n - m) + 1;
  191.   result = mklist(length, NIL);
  192.   
  193.   for (next = result, i = m; consp(next); next = cdr(next), 
  194.        (m <= n) ? i++ : i--) 
  195.     rplaca(next, cvfixnum((FIXTYPE) i));
  196.   
  197.   /* restore the stack frame */
  198.   xlpop();
  199.   
  200.   return(result);
  201. }
  202.  
  203. /* Built in ISEQ function. Generates a list of consecutive integers */
  204. LVAL xsiseq()
  205. {
  206.   int n, m;
  207.   
  208.   m = getfixnum(xlgafixnum());
  209.   if (moreargs()) n = getfixnum(xlgafixnum());
  210.   else if (m > 0) {
  211.     n = m - 1;
  212.     m = 0;
  213.   }
  214.   else if (m < 0) {
  215.     m = m + 1;
  216.     n = 0;
  217.   }
  218.   else return(NIL);
  219.   xllastarg();
  220.  
  221.   return(iseq(m, n));
  222. }
  223.  
  224. /* Built in REPEAT function */
  225. LVAL xsrepeat()
  226. {
  227.   LVAL data, result;
  228.   int reps;
  229.  
  230.   if (xlargc != 2) xlfail("wrong number of arguments");
  231.   else if (compoundp(xlargv[1])) {
  232.     xlsave1(result);
  233.     result = subr_map_elements(xsrepeat);
  234.     result = coerce_to_list(result);
  235.     result = nested_list_to_list(result, 2);
  236.     xlpop();
  237.   }
  238.   else {
  239.     data = xlgetarg();
  240.     reps = getfixnum(checknonnegint(xlgetarg()));
  241.     xllastarg();
  242.     result = lrepeat(data, reps);
  243.   }
  244.   return(result);
  245. }
  246.  
  247. /**************************************************************************/
  248. /**                                                                      **/
  249. /**               Subset Selection and Mutation Functions                **/
  250. /**                                                                      **/
  251. /**************************************************************************/
  252.  
  253. /* is x an ordered list of nonnegative positive integers? */
  254. LOCAL ordered_nneg_seq(x)
  255.      LVAL x;
  256. {
  257.   LVAL elem;
  258.   int n, i, length;
  259.  
  260.   length = (simplevectorp(x)) ? getsize(x) : 0;
  261.  
  262.   if (sequencep(x)) {
  263.     for (n = 0, i = 0; consp(x) || i < length; i++) {
  264.       elem = checknonnegint(getnextelement(&x, i));
  265.       if (n > getfixnum(elem)) return(FALSE);
  266.       else n = getfixnum(elem);
  267.     }
  268.     return(TRUE);
  269.   }
  270.   else return(FALSE);
  271. }
  272.       
  273. /* select or set the subsequence corresponding to the specified indices */
  274. LVAL subsequence(x, indices, set_values, values)
  275.      LVAL x, indices, values;
  276.      int set_values;
  277. {
  278.   int rlen, dlen, vlen, i, j;
  279.   LVAL data, result, nextx, nextr, index, elem;
  280.  
  281.   /* Check the input data */
  282.   if (! sequencep(x)) xlerror("not a sequence", x);
  283.   if (set_values && ! sequencep(values))
  284.     xlerror(" bad value sequence", values);
  285.  
  286.   /* protect some pointers */
  287.   xlstkcheck(2)
  288.   xlsave(result);
  289.   xlsave(data);
  290.  
  291.   /* Find the data sizes */
  292.   data =  (ordered_nneg_seq(indices)) ? x : coerce_to_vector(x);
  293.   dlen = (vectorp(data)) ? getsize(data) : llength(data);
  294.   rlen = (vectorp(indices)) ? getsize(indices) : llength(indices);
  295.   if (set_values) {
  296.     vlen = (vectorp(values)) ? getsize(values) : llength(values);
  297.     if (vlen != rlen && indices != s_true) 
  298.       xlfail("value and index sequences do not match");
  299.   }
  300.  
  301.   /* set up the result/value sequence */
  302.   if (set_values)     result = values;
  303.   else result = (listp(x)) ? mklist(rlen, NIL) : newvector(rlen);
  304.  
  305.   /* get or set the sequence elements */
  306.   if (indices == s_true) /* do all indices */
  307.     if (set_values)
  308.       for (i = 0; i < dlen; i++)
  309.     setnextelement(&x, i, getnextelement(&values, i));
  310.     else
  311.       result = x;
  312.   else if (sequencep(indices)) { 
  313.     if (set_values) {
  314.       for (nextx = x, nextr = result, i = 0, j = 0; i < rlen; i++) {
  315.     index = getnextelement(&indices, i);
  316.     if (dlen <= getfixnum(index)) xlerror("index out of range", index);
  317.     elem = getnextelement(&result, i);
  318.     if (listp(x)) {
  319.       if (j > getfixnum(index)) {
  320.         j = 0;
  321.         nextx = x;
  322.       }
  323.       for (; j < getfixnum(index) && consp(nextx);
  324.            j++, nextx = cdr(nextx))
  325.         ;
  326.       rplaca(nextx, elem);
  327.     }
  328.     else 
  329.       setelement(x, getfixnum(index), elem);
  330.       }
  331.     }
  332.     else 
  333.       for (nextx = data, nextr = result, i = 0, j = 0; i < rlen; i++) {
  334.     index = getnextelement(&indices, i);
  335.     if (dlen <= getfixnum(index)) xlerror("index out of range", index);
  336.     if (listp(data)) { /* indices must be ordered */
  337.       for (; j < getfixnum(index) && consp(nextx); j++, nextx = cdr(nextx))
  338.         ;
  339.       elem = car(nextx);
  340.     }
  341.     else 
  342.       elem = getelement(data, getfixnum(index));
  343.     setnextelement(&nextr, i, elem);
  344.       }
  345.   }
  346.   else xlerror("bad indices", indices);
  347.   
  348.   /* restore the stack frame */
  349.   xlpopn(2);
  350.   
  351.   return(result);
  352. }
  353.  
  354. /* translate row major index in resulting submatrix to row major index in */
  355. /* the original matrix                                                    */
  356. old_rowmajor_index(index, indices, dim, olddim)
  357.      int index;
  358.      LVAL indices, dim, olddim;
  359. {
  360.   int face, oldface, rank, i, oldindex;
  361.   
  362.   rank = getsize(dim);
  363.   
  364.   for (face = 1, oldface = 1, i = 0; i < rank; i++) {
  365.     face *= getfixnum(getelement(dim, i));
  366.     oldface *= getfixnum(getelement(olddim, i));
  367.   }
  368.   
  369.   for (oldindex = 0, i = 0; i < rank; i++) {
  370.     face /= getfixnum(getelement(dim, i));
  371.     oldface /= getfixnum(getelement(olddim, i));
  372.     oldindex +=
  373.       oldface *
  374.     getfixnum(getelement(getelement(indices, i), index / face));
  375.     index = index % face;
  376.   }
  377.   return(oldindex);
  378. }
  379.  
  380. /* extract or set subarray for the indices from a displaced array */
  381. LVAL subarray(a, indexlist, set_values, values)
  382.      LVAL a, indexlist, values;
  383.      int set_values;
  384. {
  385.   LVAL indices, index, dim, vdim, data, result_data, olddim, result;
  386.   int rank, n, i, j, k;
  387.   
  388.   /* protect some pointers */
  389.   xlstkcheck(4);
  390.   xlsave(indices);
  391.   xlsave(dim);
  392.   xlsave(olddim);
  393.   xlsave(result);
  394.  
  395.   if (! displacedarrayp(a)) xlerror("not a displaced array", a);
  396.   if (! listp(indexlist)) xlerror("bad index list", indices);
  397.   if (llength(indexlist) != arrayrank(a)) xlfail("wrong number of indices");
  398.  
  399.   indices = coerce_to_vector(indexlist);
  400.   
  401.   olddim = displacedarraydim(a);
  402.   olddim = coerce_to_vector(olddim);
  403.  
  404.   /* compute the result dimension vector and fix up the indices */
  405.   rank = arrayrank(a);
  406.   dim = newvector(rank);
  407.   for (i = 0; i < rank; i++) {
  408.     index = getelement(indices, i);
  409.     n = getfixnum(getelement(olddim, i));
  410.     if (index == s_true) {
  411.       index = newvector(n);
  412.       setelement(indices, i, index);
  413.       for (j = 0; j < n; j++)
  414.     setelement(index, j, cvfixnum((FIXTYPE) j));
  415.     }
  416.     else {
  417.       index = coerce_to_vector(index);
  418.       k = getsize(index);
  419.       for (j = 0; j < k; j++) 
  420.     if (n <= getfixnum(checknonnegint(getelement(index, j))))
  421.       xlerror("index out of bounds", getelement(index, j));
  422.       setelement(indices, i, index);
  423.     }
  424.     setelement(dim, i, cvfixnum((FIXTYPE) getsize(index)));
  425.   }
  426.     
  427.   /* set up the result or check the values*/
  428.   if (set_values) {
  429.     if (! compoundp(values))
  430.       result = newarray(dim, s_ielement, values);
  431.     else {
  432.       if (! displacedarrayp(values) || rank != arrayrank(values))
  433.     xlerror("bad values array", values);
  434.       vdim = displacedarraydim(values);
  435.       for (i = 0; i < rank; i++) 
  436.     if (getfixnum(getnextelement(&vdim, i)) 
  437.         != getfixnum(getelement(dim, i)))
  438.       xlerror("bad value array dimensions", values);
  439.       result = values;
  440.     }
  441.   }
  442.   else
  443.     result = newarray(dim, NIL, NIL);
  444.  
  445.   /* compute the result or set the values */
  446.   data = arraydata(a);
  447.   result_data = arraydata(result);
  448.   n = getsize(result_data);
  449.   for (i = 0; i < n; i++) {
  450.     k = old_rowmajor_index(i, indices, dim, olddim);
  451.     if (0 > k || k >= getsize(data)) xlfail("index out of range");
  452.     if (set_values)
  453.       setelement(data, k, getelement(result_data, i));
  454.     else
  455.       setelement(result_data, i, getelement(data, k));
  456.   }
  457.   
  458.   /* restore the stack frame */
  459.   xlpopn(4);
  460.   
  461.   return(result);
  462. }
  463.  
  464. /* are all arguments beyond the first fixnums? */
  465. LOCAL allfixargs()
  466. {
  467.   int i;
  468.   
  469.   for (i = 1; i < xlargc; i++) 
  470.     if (! fixp(xlargv[i])) return(FALSE);
  471.   return(TRUE);
  472. }
  473.  
  474. /* Built in SELECT function */
  475. LVAL xsselect()
  476. {
  477.   LVAL x, indices, result;
  478.   
  479.   if (allfixargs()) {
  480.     if (displacedarrayp(peekarg(0))) result = xsaref();
  481.     else result = xselt();
  482.   }
  483.   else if (sequencep(peekarg(0))) {
  484.     x = xlgetarg();
  485.     indices = xlgetarg();
  486.     result = subsequence(x, indices, FALSE, NIL);
  487.   }
  488.   else if (displacedarrayp(peekarg(0))) {
  489.     xlsave1(indices);
  490.     x = xlgetarg();
  491.     indices = makearglist(xlargc, xlargv);
  492.     result = subarray(x, indices, FALSE, NIL);
  493.     xlpop();
  494.   }
  495.   else xlbadtype(xlgetarg());
  496.  
  497.   return(result);
  498. }
  499.  
  500. static void setcons(x, first, rest)
  501.     LVAL x, first, rest;
  502. {
  503.   x->n_type = CONS;
  504.   rplaca(x, first);
  505.   rplacd(x, rest);
  506. }
  507.  
  508. /* Built in SET-SELECT (SETF method for SELECT) */
  509. /* This function uses node data to avoid creating garbage nodes. */
  510. /* This use of nodes *should* be safe, since there *should* be   */
  511. /* no chance of a garbage collection during this operation.      */
  512. LVAL xssetselect()
  513. {
  514.   LVAL x, indices, values, next;
  515.   struct node index_node, value_node;
  516.   LVAL i_list = &index_node, v_list = &value_node;
  517.   
  518.   xlsave1(indices);
  519.   xlsave1(values);
  520.  
  521.   x = xlgetarg();
  522.   indices = makearglist(xlargc, xlargv);
  523.   if (! consp(cdr(indices))) xltoofew();
  524.   else {
  525.     for (next = indices; consp(cdr(cdr(next))); next = cdr(next))
  526.       ;
  527.     values = car(cdr(next));
  528.     rplacd(next, NIL);
  529.   }
  530.  
  531.   if (sequencep(x)) {
  532.     if (! consp(indices)) xlerror("bad indices", indices);
  533.     indices = car(indices);
  534.     if (fixp(indices)) {
  535.       setcons(i_list, indices, NIL);
  536.       setcons(v_list, values, NIL);
  537.       subsequence(x, i_list, TRUE, v_list);
  538.     }
  539.     else
  540.       subsequence(x, indices, TRUE, values);
  541.   }
  542.   else if (displacedarrayp(x))
  543.     subarray(x, indices, TRUE, values);
  544.   else xlbadtype(x);
  545.  
  546.   xlpopn(2);
  547.  
  548.   return(values);
  549. }
  550.  
  551. /**************************************************************************/
  552. /**                                                                      **/
  553. /**                     Array Permutation Function                       **/
  554. /**                                                                      **/
  555. /**************************************************************************/
  556.  
  557.  
  558. /* permute x into y using perm; all should be vectors; If check is TRUE */
  559. /* the routine will check to make sure no indices are reused, but x     */
  560. /* will be destroyed.                                                   */
  561. static void permute_indices(x, y, perm, check) 
  562.      LVAL x, y, perm;
  563.      int check;
  564. {
  565.   LVAL index;
  566.   int rank, i, k;
  567.  
  568.   rank = getsize(x);
  569.   for (i = 0; i < rank; i++) {
  570.     index = getelement(perm, i);
  571.     if (! fixp(index)) xlerror("bad permutation sequence", perm);
  572.     k = getfixnum(index);
  573.     if (k < 0 || k >= rank) xlerror("bad permutation sequence", perm);
  574.     setelement(y, i, getelement(x, k));
  575.     if (check)
  576.       setelement(x, k, NIL); /* to insure dimensions are not re-used */
  577.   }
  578. }
  579.  
  580. /* compute indices in a from rowmajor index k, put in vector result */
  581. /* The indices are stored in cons cells, which are treated locally  */
  582. /* fixnums. This SEEMS to be safe since it is entirely local, but   */
  583. /* it may be dangerous......                                        */
  584. static void indices_from_rowmajor(a, k, result)
  585.      LVAL a, result;
  586.      int k;
  587. {
  588.   LVAL next, dim;
  589.   int face, i, rank;
  590.   
  591.   if (! displacedarrayp(a)) xlerror("not a displaced array", a);
  592.   if (0 > k || k >= getsize(arraydata(a))) xlfail("index out of range");
  593.   
  594.   dim = displacedarraydim(a);
  595.   rank = arrayrank(a);
  596.   
  597.   for (i = 0, face = 1, next = dim; i < rank; i++)
  598.     face *= getfixnum(getnextelement(&next, i));
  599.  
  600.   for (i = 0, next = dim; i < rank; i++) {
  601.     face /= getfixnum(getnextelement(&next, i));
  602.     setfixnum(getelement(result, i),(FIXTYPE) k / face);
  603.     k = k % face;
  604.   }
  605. }
  606.  
  607. /* Translate row major index in original array to row major index in new */
  608. /* array. Use indices vectors and ilist for temporary storage.           */
  609. static translate_index(i, result, x, perm, indices, oldindices, ilist)
  610.      LVAL result, x, perm, indices, oldindices, ilist;
  611.      int i;
  612. {
  613.   LVAL next;
  614.   int rank, k;
  615.  
  616.   rank = arrayrank(x);
  617.  
  618.   indices_from_rowmajor(x, i, oldindices); 
  619.   permute_indices(oldindices, indices, perm, FALSE);
  620.  
  621.   for (next = ilist, k = 0; k < rank && consp(next); k++, next = cdr(next))
  622.     rplaca(next, getelement(indices, k));
  623.  
  624.   return(rowmajorindex(result, ilist, FALSE));
  625. }
  626.  
  627. /* Built in PERMUTE-ARRAY function */
  628. LVAL xspermutearray()
  629. {
  630.   LVAL x, perm, result, data, result_data, dim, olddim, indices;
  631.   LVAL oldindices, ilist;
  632.   int rank, i, k, n;
  633.  
  634.   /* protect some pointers */
  635.   xlstkcheck(7);
  636.   xlsave(result);
  637.   xlsave(dim);
  638.   xlsave(olddim);
  639.   xlsave(indices);
  640.   xlsave(oldindices);
  641.   xlsave(perm);
  642.   xlsave(ilist);
  643.  
  644.   /* Get and ckeck the arguments */
  645.   x = xsgetdisplacedarray();
  646.   perm = xsgetsequence();
  647.   perm = coerce_to_vector(perm);
  648.   if (getsize(perm) != arrayrank(x)) xlerror("bad permutation sequence", perm);
  649.   xllastarg();
  650.  
  651.   /* get old dimension vector */
  652.   olddim = coerce_to_vector(displacedarraydim(x));
  653.   rank = getsize(perm);
  654.  
  655.   /* construct new dimension vector */
  656.   dim = newvector(rank);
  657.   olddim = copyvector(olddim); /* since permute_indices will destroy this */
  658.   permute_indices(olddim, dim, perm, TRUE);
  659.  
  660.   /* make result array and the index vectors and lists */
  661.   result = newarray(dim, NIL, NIL);
  662.   indices = newvector(rank);
  663.   oldindices = newvector(rank);
  664.   for (i = 0; i < rank; i++)
  665.     setelement(oldindices, i, consa(NIL));
  666.   ilist = mklist(rank, NIL);
  667.  
  668.   /* fill in the result */
  669.   data = arraydata(x);
  670.   result_data = arraydata(result);
  671.   if (getsize(data) != getsize(result_data)) xlfail("bad data");
  672.   n = getsize(data);
  673.   for (i = 0; i < n; i++) {
  674.     k = translate_index(i, result, x, perm, indices, oldindices, ilist);
  675.     setelement(result_data, k, getelement(data, i));
  676.   }
  677.  
  678.   /* restore stack */
  679.   xlpopn(7);
  680.  
  681.   return(result);
  682. }
  683.  
  684. #ifdef SAVERESTORE
  685. /* xrestore - restore a saved memory image */
  686. LVAL xsrestore()
  687. {
  688.   extern jmp_buf top_level;
  689.   unsigned char *name;
  690.   LVAL hlist;
  691.  
  692.   /* get the file name, verbose flag and print flag */
  693.   name = getstring(xlgetfname());
  694.   xllastarg();
  695.  
  696.   /* dispose of all hardware objects */
  697.   if (consp(getvalue(s_hardware_objects))) {
  698.     xlsave1(hlist);
  699.     hlist = copylist(getvalue(s_hardware_objects));
  700.     for (; consp(hlist); hlist = cdr(hlist))
  701.       send_message(car(cdr(cdr(car(hlist)))), sk_dispose);
  702.     xlpop();
  703.   }
  704.   
  705.   /* restore the saved memory image */
  706.   if (!xlirestore(name))
  707.   return (NIL);
  708.  
  709.   /* restore hardware items (this may be dangerous) */
  710.   if (symbolp(s_listener) && objectp(getvalue(s_listener)))
  711.     send_message(getvalue(s_listener), sk_allocate);
  712.   if (consp(getvalue(s_hardware_objects))) {
  713.     xlsave1(hlist);
  714.     hlist = copylist(getvalue(s_hardware_objects));
  715.     setvalue(s_hardware_objects, NIL);
  716.     for (; consp(hlist); hlist = cdr(hlist))
  717.       send_message(car(cdr(cdr(car(hlist)))), sk_allocate);
  718.     xlpop();
  719.   }
  720.   
  721.   /* return directly to the top level */
  722.   stdputstr("[ returning to the top level ]\n");
  723.   longjmp(top_level,1);
  724. }
  725. #endif
  726.