home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp2.arc / XLSYS.C < prev   
Encoding:
C/C++ Source or Header  |  1985-01-01  |  3.3 KB  |  159 lines
  1. /* xlsys.c - xlisp builtin system functions */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *xlstack;
  7. extern int anodes;
  8.  
  9. /* external symbols */
  10. extern NODE *a_subr,*a_fsubr;
  11. extern NODE *a_list,*a_sym,*a_int,*a_str,*a_obj,*a_fptr;
  12. extern NODE *true;
  13.  
  14. /* xload - direct input from a file */
  15. NODE *xload(args)
  16.   NODE *args;
  17. {
  18.     NODE *oldstk,fname,*val;
  19.     int vflag,pflag;
  20.  
  21.     /* create a new stack frame */
  22.     oldstk = xlsave(&fname,NULL);
  23.  
  24.     /* get the file name, verbose flag and print flag */
  25.     fname.n_ptr = xlmatch(STR,&args);
  26.     vflag = (args ? xlarg(&args) != NULL : TRUE);
  27.     pflag = (args ? xlarg(&args) != NULL : FALSE);
  28.     xllastarg(args);
  29.  
  30.     /* load the file */
  31.     val = (xlload(fname.n_ptr->n_str,vflag,pflag) ? true : NULL);
  32.  
  33.     /* restore the previous stack frame */
  34.     xlstack = oldstk;
  35.  
  36.     /* return the status */
  37.     return (val);
  38. }
  39.  
  40. /* xgc - xlisp function to force garbage collection */
  41. NODE *xgc(args)
  42.   NODE *args;
  43. {
  44.     /* make sure there aren't any arguments */
  45.     xllastarg(args);
  46.  
  47.     /* garbage collect */
  48.     gc();
  49.  
  50.     /* return null */
  51.     return (NULL);
  52. }
  53.  
  54. /* xexpand - xlisp function to force memory expansion */
  55. NODE *xexpand(args)
  56.   NODE *args;
  57. {
  58.     NODE *val;
  59.     int n,i;
  60.  
  61.     /* get the new number to allocate */
  62.     if (args == NULL)
  63.     n = 1;
  64.     else
  65.     n = xlmatch(INT,&args)->n_int;
  66.  
  67.     /* make sure there aren't any more arguments */
  68.     xllastarg(args);
  69.  
  70.     /* allocate more segments */
  71.     for (i = 0; i < n; i++)
  72.     if (!addseg())
  73.         break;
  74.  
  75.     /* return the number of segments added */
  76.     val = newnode(INT);
  77.     val->n_int = i;
  78.     return (val);
  79. }
  80.  
  81. /* xalloc - xlisp function to set the number of nodes to allocate */
  82. NODE *xalloc(args)
  83.   NODE *args;
  84. {
  85.     NODE *val;
  86.     int n,oldn;
  87.  
  88.     /* get the new number to allocate */
  89.     n = xlmatch(INT,&args)->n_int;
  90.  
  91.     /* make sure there aren't any more arguments */
  92.     xllastarg(args);
  93.  
  94.     /* set the new number of nodes to allocate */
  95.     oldn = anodes;
  96.     anodes = n;
  97.  
  98.     /* return the old number */
  99.     val = newnode(INT);
  100.     val->n_int = oldn;
  101.     return (val);
  102. }
  103.  
  104. /* xmem - xlisp function to print memory statistics */
  105. NODE *xmem(args)
  106.   NODE *args;
  107. {
  108.     /* make sure there aren't any arguments */
  109.     xllastarg(args);
  110.  
  111.     /* print the statistics */
  112.     stats();
  113.  
  114.     /* return null */
  115.     return (NULL);
  116. }
  117.  
  118. /* xtype - return type of a thing */
  119. NODE *xtype(args)
  120.     NODE *args;
  121. {
  122.     NODE *arg;
  123.  
  124.     if (!(arg = xlarg(&args)))
  125.     return (NULL);
  126.  
  127.     switch (ntype(arg)) {
  128.     case SUBR:    return (a_subr);
  129.     case FSUBR:    return (a_fsubr);
  130.     case LIST:    return (a_list);
  131.     case SYM:    return (a_sym);
  132.     case INT:    return (a_int);
  133.     case STR:    return (a_str);
  134.     case OBJ:    return (a_obj);
  135.     case FPTR:    return (a_fptr);
  136.     default:    xlfail("bad node type");
  137.     }
  138. }
  139.  
  140. /* xbaktrace - print the trace back stack */
  141. NODE *xbaktrace(args)
  142.   NODE *args;
  143. {
  144.     int n;
  145.  
  146.     n = (args ? xlmatch(INT,&args)->n_int : -1);
  147.     xllastarg(args);
  148.     xlbaktrace(n);
  149.     return (NULL);
  150. }
  151.  
  152. /* xexit - get out of xlisp */
  153. NODE *xexit(args)
  154.   NODE *args;
  155. {
  156.     xllastarg(args);
  157.     exit();
  158. }
  159.