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