home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_disks / 300-399 / ff386.lzh / XLispStat / src1.lzh / XLisp / xlsys.c < prev   
C/C++ Source or Header  |  1990-10-03  |  3KB  |  161 lines
  1. /* xlsys.c - xlisp builtin system functions */
  2. /* Copyright (c) 1989, by David Michael Betz.                            */
  3. /* You may give out copies of this software; for conditions see the file */
  4. /* COPYING included with this distribution.                              */
  5.  
  6. #include "xlisp.h"
  7. #include "osdef.h"
  8. #ifdef ANSI
  9. #include "xlproto.h"
  10. #include "osproto.h"
  11. #else
  12. #include "xlfun.h"
  13. #include "osfun.h"
  14. #endif ANSI
  15. #include "xlvar.h"
  16. #include "xlsvar.h"
  17.  
  18. /* xload - read and evaluate expressions from a file */
  19. LVAL xload()
  20. {
  21.     unsigned char *name;
  22.     int vflag,pflag;
  23.     LVAL arg;
  24.  
  25.     /* get the file name */
  26.     name = getstring(xlgetfname());
  27.  
  28.     /* get the :verbose flag */
  29.     if (xlgetkeyarg(k_verbose,&arg))
  30.     vflag = (arg != NIL);
  31.     else
  32.     vflag = TRUE;
  33.  
  34.     /* get the :print flag */
  35.     if (xlgetkeyarg(k_print,&arg))
  36.     pflag = (arg != NIL);
  37.     else
  38.     pflag = FALSE;
  39.  
  40.     /* load the file */
  41.     return (xlload(name,vflag,pflag) ? true : NIL);
  42. }
  43.  
  44. /* xtranscript - open or close a transcript file */
  45. LVAL xtranscript()
  46. {
  47.     unsigned char *name;
  48.  
  49.     /* get the transcript file name */
  50.     name = (moreargs() ? getstring(xlgetfname()) : NULL);
  51.     xllastarg();
  52.  
  53.     /* close the current transcript */
  54.     if (tfp) osclose(tfp);
  55.  
  56.     /* open the new transcript */
  57.     tfp = (name ? osaopen(name,"w") : NULL);
  58.  
  59.     /* return T if a transcript is open, NIL otherwise */
  60.     return (tfp ? true : NIL);
  61. }
  62.  
  63. /* xtype - return type of a thing */
  64. LVAL xtype()
  65. {
  66.     LVAL arg;
  67.  
  68.     if (!(arg = xlgetarg()))
  69.     return (NIL);
  70.  
  71.     switch (ntype(arg)) {
  72.     case SUBR:        return (a_subr);
  73.     case FSUBR:        return (a_fsubr);
  74.     case CONS:        return (a_cons);
  75.     case SYMBOL:    return (a_symbol);
  76.     case FIXNUM:    return (a_fixnum);
  77.     case FLONUM:    return (a_flonum);
  78.     case STRING:    return (a_string);
  79.     case OBJECT:    return (a_object);
  80.     case STREAM:    return (a_stream);
  81.     case VECTOR:    return (s_vector);
  82.     case CLOSURE:    return (a_closure);
  83.     case CHAR:        return (a_char);
  84.     case USTREAM:    return (a_ustream);
  85.     case COMPLEX:    return (a_complex);      /* L. Tierney */
  86.     case DISPLACED_ARRAY:return (a_array);       /* L. Tierney */
  87.     case STRUCT:    return (getelement(arg,0));
  88.     default:        xlfail("bad node type");
  89.     }
  90. }
  91.  
  92. /* xbaktrace - print the trace back stack */
  93. LVAL xbaktrace()
  94. {
  95.     LVAL num;
  96.     int n;
  97.  
  98.     if (moreargs()) {
  99.     num = xlgafixnum();
  100.     n = getfixnum(num);
  101.     }
  102.     else
  103.     n = -1;
  104.     xllastarg();
  105.     xlbaktrace(n);
  106.     return (NIL);
  107. }
  108.  
  109. /* xexit - get out of xlisp */
  110. LVAL xexit()
  111. {
  112.     xllastarg();
  113.     wrapup();
  114.     return(NIL);  /* to keep compilers happy - L. Tierney */
  115. }
  116.  
  117. /* xpeek - peek at a location in memory */
  118. LVAL xpeek()
  119. {
  120.     LVAL num;
  121.     int *adr;
  122.  
  123.     /* get the address */
  124.     num = xlgafixnum(); adr = (int *)getfixnum(num);
  125.     xllastarg();
  126.  
  127.     /* return the value at that address */
  128.     return (cvfixnum((FIXTYPE)*adr));
  129. }
  130.  
  131. /* xpoke - poke a value into memory */
  132. LVAL xpoke()
  133. {
  134.     LVAL val;
  135.     int *adr;
  136.  
  137.     /* get the address and the new value */
  138.     val = xlgafixnum(); adr = (int *)getfixnum(val);
  139.     val = xlgafixnum();
  140.     xllastarg();
  141.  
  142.     /* store the new value */
  143.     *adr = (int)getfixnum(val);
  144.  
  145.     /* return the new value */
  146.     return (val);
  147. }
  148.  
  149. /* xaddrs - get the address of an XLISP node */
  150. LVAL xaddrs()
  151. {
  152.     LVAL val;
  153.  
  154.     /* get the node */
  155.     val = xlgetarg();
  156.     xllastarg();
  157.  
  158.     /* return the address of the node */
  159.     return (cvfixnum((FIXTYPE)val));
  160. }
  161.