home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispdos / source / xlsys.c < prev   
Text File  |  1986-06-01  |  5KB  |  225 lines
  1. /* xlsys.c - xlisp builtin system functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern NODE *xlenv;
  10. extern int anodes;
  11. extern FILE *tfp;
  12.  
  13. /* external symbols */
  14. extern NODE *a_subr,*a_fsubr;
  15. extern NODE *a_list,*a_sym,*a_int,*a_float,*a_str,*a_obj,*a_fptr,*a_vect;
  16. extern NODE *true;
  17.  
  18. /* external routines */
  19. extern FILE *fopen();
  20.  
  21. /* xload - direct input from a file */
  22. NODE *xload(args)
  23.   NODE *args;
  24. {
  25.     int vflag,pflag;
  26.     NODE *fname;
  27.     char *name;
  28.  
  29.     /* get the file name, verbose flag and print flag */
  30.     fname = xlarg(&args);
  31.     vflag = (args ? xlarg(&args) != NIL : TRUE);
  32.     pflag = (args ? xlarg(&args) != NIL : FALSE);
  33.     xllastarg(args);
  34.  
  35.     /* get the filename string */
  36.     if (symbolp(fname))
  37.     name = getstring(getpname(fname));
  38.     else if (stringp(fname))
  39.     name = getstring(fname);
  40.     else
  41.     xlerror("bad argument type",fname);
  42.  
  43.     /* load the file */
  44.     return (xlload(name,vflag,pflag) ? true : NIL);
  45. }
  46.  
  47. /* xtranscript - open or close a transcript file */
  48. NODE *xtranscript(args)
  49.   NODE *args;
  50. {
  51.     char *name;
  52.  
  53.     /* get the transcript file name */
  54.     name = (args ? getstring(xlmatch(STR,&args)) : NULL);
  55.     xllastarg(args);
  56.  
  57.     /* close the current transcript */
  58.     if (tfp) fclose(tfp);
  59.  
  60.     /* open the new transcript */
  61.     tfp = (name ? fopen(name,"w") : NULL);
  62.  
  63.     /* return T if a transcript is open, NIL otherwise */
  64.     return (tfp ? true : NIL);
  65. }
  66.  
  67. /* xgc - xlisp function to force garbage collection */
  68. NODE *xgc(args)
  69.   NODE *args;
  70. {
  71.     /* make sure there aren't any arguments */
  72.     xllastarg(args);
  73.  
  74.     /* garbage collect */
  75.     gc();
  76.  
  77.     /* return nil */
  78.     return (NIL);
  79. }
  80.  
  81. /* xexpand - xlisp function to force memory expansion */
  82. NODE *xexpand(args)
  83.   NODE *args;
  84. {
  85.     int n,i;
  86.  
  87.     /* get the new number to allocate */
  88.     n = (args ? getfixnum(xlmatch(INT,&args)) : 1);
  89.     xllastarg(args);
  90.  
  91.     /* allocate more segments */
  92.     for (i = 0; i < n; i++)
  93.     if (!addseg())
  94.         break;
  95.  
  96.     /* return the number of segments added */
  97.     return (cvfixnum((FIXNUM)i));
  98. }
  99.  
  100. /* xalloc - xlisp function to set the number of nodes to allocate */
  101. NODE *xalloc(args)
  102.   NODE *args;
  103. {
  104.     int n,oldn;
  105.  
  106.     /* get the new number to allocate */
  107.     n = getfixnum(xlmatch(INT,&args));
  108.  
  109.     /* make sure there aren't any more arguments */
  110.     xllastarg(args);
  111.  
  112.     /* set the new number of nodes to allocate */
  113.     oldn = anodes;
  114.     anodes = n;
  115.  
  116.     /* return the old number */
  117.     return (cvfixnum((FIXNUM)oldn));
  118. }
  119.  
  120. /* xmem - xlisp function to print memory statistics */
  121. NODE *xmem(args)
  122.   NODE *args;
  123. {
  124.     /* make sure there aren't any arguments */
  125.     xllastarg(args);
  126.  
  127.     /* print the statistics */
  128.     stats();
  129.  
  130.     /* return nil */
  131.     return (NIL);
  132. }
  133.  
  134. /* xtype - return type of a thing */
  135. NODE *xtype(args)
  136.     NODE *args;
  137. {
  138.     NODE *arg;
  139.  
  140.     if (!(arg = xlarg(&args)))
  141.     return (NIL);
  142.  
  143.     switch (ntype(arg)) {
  144.     case SUBR:    return (a_subr);
  145.     case FSUBR:    return (a_fsubr);
  146.     case LIST:    return (a_list);
  147.     case SYM:    return (a_sym);
  148.     case INT:    return (a_int);
  149.     case FLOAT:    return (a_float);
  150.     case STR:    return (a_str);
  151.     case OBJ:    return (a_obj);
  152.     case FPTR:    return (a_fptr);
  153.     case VECT:    return (a_vect);
  154.     default:    xlfail("bad node type");
  155.     }
  156. }
  157.  
  158. /* xbaktrace - print the trace back stack */
  159. NODE *xbaktrace(args)
  160.   NODE *args;
  161. {
  162.     int n;
  163.  
  164.     n = (args ? getfixnum(xlmatch(INT,&args)) : -1);
  165.     xllastarg(args);
  166.     xlbaktrace(n);
  167.     return (NIL);
  168. }
  169.  
  170. /* xexit - get out of xlisp */
  171. NODE *xexit(args)
  172.   NODE *args;
  173. {
  174.     xllastarg(args);
  175.     wrapup();
  176. }
  177.  
  178. /* xpeek - peek at a location in memory */
  179. NODE *xpeek(args)
  180.   NODE *args;
  181. {
  182.     int *adr;
  183.  
  184.     /* get the address */
  185.     adr = (int *)getfixnum(xlmatch(INT,&args));
  186.     xllastarg(args);
  187.  
  188.     /* return the value at that address */
  189.     return (cvfixnum((FIXNUM)*adr));
  190. }
  191.  
  192. /* xpoke - poke a value into memory */
  193. NODE *xpoke(args)
  194.   NODE *args;
  195. {
  196.     int *adr;
  197.     NODE *val;
  198.  
  199.     /* get the address and the new value */
  200.     adr = (int *)getfixnum(xlmatch(INT,&args));
  201.     val = xlmatch(INT,&args);
  202.     xllastarg(args);
  203.  
  204.     /* store the new value */
  205.     *adr = (int)getfixnum(val);
  206.  
  207.     /* return the new value */
  208.     return (val);
  209. }
  210.  
  211. /* xaddrs - get the address of an XLISP node */
  212. NODE *xaddrs(args)
  213.   NODE *args;
  214. {
  215.     NODE *val;
  216.  
  217.     /* get the node */
  218.     val = xlarg(&args);
  219.     xllastarg(args);
  220.  
  221.     /* return the address of the node */
  222.     return (cvfixnum((FIXNUM)val));
  223. }
  224.  
  225.