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