home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 2: PC / frozenfish_august_1995.bin / bbs / d00xx / d0003.lha / xlisp / xlsys.c < prev   
C/C++ Source or Header  |  1985-12-26  |  3KB  |  154 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) != NIL : TRUE);
  27.     pflag = (args ? xlarg(&args) != NIL : FALSE);
  28.     xllastarg(args);
  29.  
  30.     /* load the file */
  31.     val = (xlload(fname.n_ptr->n_str,vflag,pflag) ? true : NIL);
  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 nil */
  51.     return (NIL);
  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.     n = (args ? xlmatch(INT,&args)->n_int : 1);
  63.     xllastarg(args);
  64.  
  65.     /* allocate more segments */
  66.     for (i = 0; i < n; i++)
  67.     if (!addseg())
  68.         break;
  69.  
  70.     /* return the number of segments added */
  71.     val = newnode(INT);
  72.     val->n_int = i;
  73.     return (val);
  74. }
  75.  
  76. /* xalloc - xlisp function to set the number of nodes to allocate */
  77. NODE *xalloc(args)
  78.   NODE *args;
  79. {
  80.     NODE *val;
  81.     int n,oldn;
  82.  
  83.     /* get the new number to allocate */
  84.     n = xlmatch(INT,&args)->n_int;
  85.  
  86.     /* make sure there aren't any more arguments */
  87.     xllastarg(args);
  88.  
  89.     /* set the new number of nodes to allocate */
  90.     oldn = anodes;
  91.     anodes = n;
  92.  
  93.     /* return the old number */
  94.     val = newnode(INT);
  95.     val->n_int = oldn;
  96.     return (val);
  97. }
  98.  
  99. /* xmem - xlisp function to print memory statistics */
  100. NODE *xmem(args)
  101.   NODE *args;
  102. {
  103.     /* make sure there aren't any arguments */
  104.     xllastarg(args);
  105.  
  106.     /* print the statistics */
  107.     stats();
  108.  
  109.     /* return nil */
  110.     return (NIL);
  111. }
  112.  
  113. /* xtype - return type of a thing */
  114. NODE *xtype(args)
  115.     NODE *args;
  116. {
  117.     NODE *arg;
  118.  
  119.     if (!(arg = xlarg(&args)))
  120.     return (NIL);
  121.  
  122.     switch (ntype(arg)) {
  123.     case SUBR:    return (a_subr);
  124.     case FSUBR:    return (a_fsubr);
  125.     case LIST:    return (a_list);
  126.     case SYM:    return (a_sym);
  127.     case INT:    return (a_int);
  128.     case STR:    return (a_str);
  129.     case OBJ:    return (a_obj);
  130.     case FPTR:    return (a_fptr);
  131.     default:    xlfail("bad node type");
  132.     }
  133. }
  134.  
  135. /* xbaktrace - print the trace back stack */
  136. NODE *xbaktrace(args)
  137.   NODE *args;
  138. {
  139.     int n;
  140.  
  141.     n = (args ? xlmatch(INT,&args)->n_int : -1);
  142.     xllastarg(args);
  143.     xlbaktrace(n);
  144.     return (NIL);
  145. }
  146.  
  147. /* xexit - get out of xlisp */
  148. NODE *xexit(args)
  149.   NODE *args;
  150. {
  151.     xllastarg(args);
  152.     exit();
  153. }
  154.