home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / 32XLISP.ZIP / XLSYS.C < prev   
Text File  |  1988-09-17  |  3KB  |  163 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 jmp_buf top_level;
  10. extern FILE *tfp;
  11.  
  12. /* external symbols */
  13. extern LVAL a_subr,a_fsubr,a_cons,a_symbol;
  14. extern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
  15. extern LVAL a_vector,a_closure,a_char,a_ustream;
  16. extern LVAL k_verbose,k_print;
  17. extern LVAL true;
  18.  
  19. /* external routines */
  20. extern FILE *osaopen();
  21.  
  22. /* xload - read and evaluate expressions from a file */
  23. LVAL xload()
  24. {
  25.     unsigned char *name;
  26.     int vflag,pflag;
  27.     LVAL arg;
  28.  
  29.     /* get the file name */
  30.     name = getstring(xlgetfname());
  31.  
  32.     /* get the :verbose flag */
  33.     if (xlgetkeyarg(k_verbose,&arg))
  34.     vflag = (arg != NIL);
  35.     else
  36.     vflag = TRUE;
  37.  
  38.     /* get the :print flag */
  39.     if (xlgetkeyarg(k_print,&arg))
  40.     pflag = (arg != NIL);
  41.     else
  42.     pflag = FALSE;
  43.  
  44.     /* load the file */
  45.     return (xlload(name,vflag,pflag) ? true : NIL);
  46. }
  47.  
  48. /* xtranscript - open or close a transcript file */
  49. LVAL xtranscript()
  50. {
  51.     unsigned char *name;
  52.  
  53.     /* get the transcript file name */
  54.     name = (moreargs() ? getstring(xlgetfname()) : NULL);
  55.     xllastarg();
  56.  
  57.     /* close the current transcript */
  58.     if (tfp) osclose(tfp);
  59.  
  60.     /* open the new transcript */
  61.     tfp = (name ? osaopen(name,"w") : NULL);
  62.  
  63.     /* return T if a transcript is open, NIL otherwise */
  64.     return (tfp ? true : NIL);
  65. }
  66.  
  67. /* xtype - return type of a thing */
  68. LVAL xtype()
  69. {
  70.     LVAL arg;
  71.  
  72.     if (!(arg = xlgetarg()))
  73.     return (NIL);
  74.  
  75.     switch (ntype(arg)) {
  76.     case SUBR:        return (a_subr);
  77.     case FSUBR:        return (a_fsubr);
  78.     case CONS:        return (a_cons);
  79.     case SYMBOL:    return (a_symbol);
  80.     case FIXNUM:    return (a_fixnum);
  81.     case FLONUM:    return (a_flonum);
  82.     case STRING:    return (a_string);
  83.     case OBJECT:    return (a_object);
  84.     case STREAM:    return (a_stream);
  85.     case VECTOR:    return (a_vector);
  86.     case CLOSURE:    return (a_closure);
  87.     case CHAR:        return (a_char);
  88.     case USTREAM:    return (a_ustream);
  89.     case STRUCT:    return (getelement(arg,0));
  90.     default:        xlfail("bad node type");
  91.     }
  92. }
  93.  
  94. /* xbaktrace - print the trace back stack */
  95. LVAL xbaktrace()
  96. {
  97.     LVAL num;
  98.     int n;
  99.  
  100.     if (moreargs()) {
  101.     num = xlgafixnum();
  102.     n = getfixnum(num);
  103.     }
  104.     else
  105.     n = -1;
  106.     xllastarg();
  107.     xlbaktrace(n);
  108.     return (NIL);
  109. }
  110.  
  111. /* xexit - get out of xlisp */
  112. LVAL xexit()
  113. {
  114.     xllastarg();
  115.     wrapup();
  116. }
  117.  
  118. /* xpeek - peek at a location in memory */
  119. LVAL xpeek()
  120. {
  121.     LVAL num;
  122.     int *adr;
  123.  
  124.     /* get the address */
  125.     num = xlgafixnum(); adr = (int *)getfixnum(num);
  126.     xllastarg();
  127.  
  128.     /* return the value at that address */
  129.     return (cvfixnum((FIXTYPE)*adr));
  130. }
  131.  
  132. /* xpoke - poke a value into memory */
  133. LVAL xpoke()
  134. {
  135.     LVAL val;
  136.     int *adr;
  137.  
  138.     /* get the address and the new value */
  139.     val = xlgafixnum(); adr = (int *)getfixnum(val);
  140.     val = xlgafixnum();
  141.     xllastarg();
  142.  
  143.     /* store the new value */
  144.     *adr = (int)getfixnum(val);
  145.  
  146.     /* return the new value */
  147.     return (val);
  148. }
  149.  
  150. /* xaddrs - get the address of an XLISP node */
  151. LVAL xaddrs()
  152. {
  153.     LVAL val;
  154.  
  155.     /* get the node */
  156.     val = xlgetarg();
  157.     xllastarg();
  158.  
  159.     /* return the address of the node */
  160.     return (cvfixnum((FIXTYPE)val));
  161. }
  162.  
  163.