home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / lisp / interpre / xlispplu / xlisp2tc / msstuff.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-04-11  |  8.7 KB  |  452 lines
  1. /* msstuff.c - ms-dos specific routines */
  2.  
  3. #include "xlisp.h"
  4.  
  5. #define LBSIZE 200
  6.  
  7. /* external variables */
  8. extern LVAL s_unbound,true;
  9. extern FILE *tfp;
  10. extern int errno;
  11.  
  12. /* local variables */
  13. static char lbuf[LBSIZE];
  14. static int lpos[LBSIZE];
  15. static int lindex;
  16. static int lcount;
  17. static int lposition;
  18. static long rseed = 1L;
  19.  
  20. #ifdef _TURBOC_
  21. #  include <dos.h>
  22. #  define xputc(c) bdos(6,c,0)
  23. #  define xcheck() bdos(6,0xFF,0)
  24.  
  25. void xinfo(void) ;
  26. void xflush(void) ;
  27.  
  28. extern unsigned _stklen = 16384u ;
  29. #endif _TURBOC_
  30.  
  31. #ifdef PROTOTYPES
  32. int xgetc(void) ;
  33. #endif PROTOTYPES
  34.  
  35. /* osinit - initialize */
  36. void osinit(banner)
  37.   char *banner;
  38. {
  39.     printf("%s\n",banner);
  40.     lposition = 0;
  41.     lindex = 0;
  42.     lcount = 0;
  43. }
  44.  
  45. /* osfinish - clean up before returning to the operating system */
  46. void osfinish()
  47. {
  48. }
  49.  
  50. /* oserror - print an error message */
  51. void oserror(msg)
  52.   char *msg;
  53. {
  54.     printf("error: %s\n",msg);
  55. }
  56.  
  57. /* osrand - return a random number between 0 and n-1 */
  58. int osrand(n)
  59.   int n;
  60. {
  61.     long k1;
  62.  
  63.     /* make sure we don't get stuck at zero */
  64.     if (rseed == 0L) rseed = 1L;
  65.  
  66.     /* algorithm taken from Dr. Dobbs Journal, November 1985, page 91 */
  67.     k1 = rseed / 127773L;
  68.     if ((rseed = 16807L * (rseed - k1 * 127773L) - k1 * 2836L) < 0L)
  69.     rseed += 2147483647L;
  70.  
  71.     /* return a random number between 0 and n-1 */
  72.     return ((int)(rseed % (long)n));
  73. }
  74.  
  75. /* osaopen - open an ascii file */
  76. #ifndef osaopen
  77. FILE *osaopen(name,mode)
  78.   char *name,*mode;
  79. {
  80.     return (fopen(name,mode));
  81. }
  82. #endif
  83.  
  84. /* osbopen - open a binary file */
  85. FILE *osbopen(name,mode)
  86.   char *name,*mode;
  87. {
  88.     char bmode[10];
  89.     strcpy(bmode,mode); strcat(bmode,"b");
  90.     return (fopen(name,bmode));
  91. }
  92.  
  93. /* osclose - close a file */
  94. #ifndef osclose
  95. int osclose(fp)
  96.   FILE *fp;
  97. {
  98.     return (fclose(fp));
  99. }
  100. #endif osclose
  101.  
  102. /* osagetc - get a character from an ascii file */
  103. #ifndef osagetc
  104. int osagetc(fp)
  105.   FILE *fp;
  106. {
  107.     return (getc(fp));
  108. }
  109. #endif
  110.  
  111. /* osaputc - put a character to an ascii file */
  112. #ifndef osaputc
  113. int osaputc(ch,fp)
  114.   int ch; FILE *fp;
  115. {
  116.     return (putc(ch,fp));
  117. }
  118. #endif
  119.  
  120. /* osbgetc - get a character from a binary file */
  121. #ifndef osbgetc
  122. int osbgetc(fp)
  123.   FILE *fp;
  124. {
  125.     return (getc(fp));
  126. }
  127. #endif osbgetc
  128.  
  129. /* osbputc - put a character to a binary file */
  130. #ifndef osbputc
  131. int osbputc(ch,fp)
  132.   int ch; FILE *fp;
  133. {
  134.     return (putc(ch,fp));
  135. }
  136. #endif
  137.  
  138. /* ostgetc - get a character from the terminal */
  139. int ostgetc()
  140. {
  141.     int ch;
  142.  
  143.     /* check for a buffered character */
  144.     if (lcount--)
  145.     return (lbuf[lindex++]);
  146.  
  147.     /* get an input line */
  148.     for (lcount = 0; ; )
  149.     switch (ch = xgetc()) {
  150.     case '\r':
  151.         lbuf[lcount++] = '\n';
  152.         xputc('\r'); xputc('\n'); lposition = 0;
  153.         if (tfp)
  154.             for (lindex = 0; lindex < lcount; ++lindex)
  155.             osaputc(lbuf[lindex],tfp);
  156.         lindex = 0; lcount--;
  157.         return (lbuf[lindex++]);
  158.     case '\010':
  159.     case '\177':
  160.         if (lcount) {
  161.             lcount--;
  162.             while (lposition > lpos[lcount]) {
  163.             xputc('\010'); xputc(' '); xputc('\010');
  164.             lposition--;
  165.             }
  166.         }
  167.         break;
  168.     case '\032':
  169.         xflush();
  170.         return (EOF);
  171.     default:
  172.         if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
  173.             lbuf[lcount] = ch;
  174.             lpos[lcount] = lposition;
  175.             if (ch == '\t')
  176.             do {
  177.                 xputc(' ');
  178.             } while (++lposition & 7);
  179.             else {
  180.             xputc(ch); lposition++;
  181.             }
  182.             lcount++;
  183.         }
  184.         else {
  185.             xflush();
  186.             switch (ch) {
  187.             case '\003':    xltoplevel();    /* control-c */
  188.             case '\007':    xlcleanup();    /* control-g */
  189.             case '\020':    xlcontinue();    /* control-p */
  190.             case '\032':    return (EOF);    /* control-z */
  191.             default:        return (ch);
  192.             }
  193.         }
  194.     }
  195. }
  196.  
  197. /* ostputc - put a character to the terminal */
  198. void ostputc(ch)
  199.   int ch;
  200. {
  201.     /* check for control characters */
  202.     oscheck();
  203.  
  204.     /* output the character */
  205.     if (ch == '\n') {
  206.     xputc('\r'); xputc('\n');
  207.     lposition = 0;
  208.     }
  209.     else {
  210.     xputc(ch);
  211.     lposition++;
  212.    }
  213.  
  214.    /* output the character to the transcript file */
  215.    if (tfp)
  216.     osaputc(ch,tfp);
  217. }
  218.  
  219. /* osflush - flush the terminal input buffer */
  220. void osflush()
  221. {
  222.     lindex = lcount = lposition = 0;
  223. }
  224.  
  225. /* oscheck - check for control characters during execution */
  226. void oscheck()
  227. {
  228.     int ch;
  229.     if (ch = xcheck())
  230.     switch (ch) {
  231.     case '\002':    /* control-b */
  232.         xflush();
  233.         xlbreak("BREAK",s_unbound);
  234.         break;
  235.     case '\003':    /* control-c */
  236.         xflush();
  237.         xltoplevel();
  238.         break;
  239.     case '\024':    /* control-t */
  240.         xinfo();
  241.         break;
  242.     }
  243. }
  244.  
  245. /* xinfo - show information on control-t */
  246. static void xinfo()
  247. {
  248.     extern int nfree,gccalls;
  249.     extern long total;
  250.     char buf[80];
  251.     sprintf(buf,"\n[ Free: %d, GC calls: %d, Total: %ld ]",
  252.         nfree,gccalls,total);
  253.     errputstr(buf);
  254. }
  255.  
  256. /* xflush - flush the input line buffer and start a new line */
  257. static void xflush()
  258. {
  259.     osflush();
  260.     ostputc('\n');
  261. }
  262.  
  263. /* xgetc - get a character from the terminal without echo */
  264. static int xgetc()
  265. {
  266.     return (bdos(7,0,0) & 0xFF);
  267. }
  268.  
  269. /* xputc - put a character to the terminal */
  270. #ifndef xputc
  271. static void xputc(ch)
  272.   int ch;
  273. {
  274.     bdos(6,ch);
  275. }
  276. #endif xputc
  277.  
  278. /* xcheck - check for a character */
  279. #ifndef xcheck
  280. static int xcheck()
  281. {
  282.     return (bdos(6,0xFF));
  283. }
  284. #endif xcheck
  285.  
  286. /* xsystem - execute a system command */
  287. LVAL xsystem()
  288. {
  289.     char *cmd="COMMAND";
  290.     if (moreargs())
  291.     cmd = (char *)getstring(xlgastring());
  292.     xllastarg();
  293.     return (system(cmd) == 0 ? true : cvfixnum((FIXTYPE)errno));
  294. }
  295.  
  296. /* xgetkey - get a key from the keyboard */
  297. LVAL xgetkey()
  298. {
  299.     xllastarg();
  300.     return (cvfixnum((FIXTYPE)xgetc()));
  301. }
  302.  
  303. /* xbutlast - (butlast list &optional (n 1)) */
  304. LVAL xbutlast( void )
  305. {
  306.    unsigned len ;
  307.    unsigned n ;
  308.    LVAL list = xlgalist() ;
  309.    LVAL p, q, result ;
  310.  
  311.    for (len = 0, p = list ; consp(p) ; len++)
  312.       p = cdr(p) ;
  313.    if (moreargs())
  314.       {
  315.       p = xlgetarg() ;
  316.       n = floatp(p) ? (unsigned) getflonum(p) : (unsigned) getfixnum(p) ;
  317.       }
  318.    else
  319.       n = 1 ;
  320.  
  321.    if (len > n)
  322.       {
  323.       p = list ;
  324.       result = q = consa(car(p)) ;
  325.       p = cdr(p) ;
  326.       }
  327.    else
  328.       return NIL ;
  329.    while (--len > n)
  330.       {
  331.       rplacd(q,consa(car(p))) ;
  332.       p = cdr(p) ;
  333.       q = cdr(q) ;
  334.       }
  335.    return result ;
  336. }
  337.  
  338. /* xnbutlast - (nbutlast list &optional (n 1)) */
  339. LVAL xnbutlast( void )
  340. {
  341.    unsigned len ;
  342.    unsigned n ;
  343.    LVAL list = xlgalist() ;
  344.    LVAL p ;
  345.  
  346.    for (len = 0, p = list ; consp(p) ; len++)
  347.       p = cdr(p) ;
  348.    if (moreargs())
  349.       {
  350.       p = xlgetarg() ;
  351.       n = floatp(p) ? (unsigned) getflonum(p) : (unsigned) getfixnum(p) ;
  352.       }
  353.    else
  354.       n = 1 ;
  355.  
  356.    p = NIL ;
  357.    if (len > n)
  358.       {
  359.       p = list ;
  360.       while (--len > n)
  361.          list = cdr(list) ;
  362.       rplacd(list,NIL) ;
  363.       }
  364.    return p ;
  365. }
  366.  
  367. LVAL _xcopytree( LVAL arg )
  368. {
  369.    if (consp(arg))
  370.       return cons(_xcopytree( car(arg) ),_xcopytree( cdr(arg) )) ;
  371.    else
  372.       return arg ;
  373. }
  374.  
  375. /* xcopytree - (copy-tree obj) */
  376. LVAL xcopytree( void )
  377. {
  378.    return _xcopytree( xlgalist() ) ;
  379. }
  380.  
  381. /* xnreverse - (nreverse list) */
  382. LVAL xnreverse( void )
  383. {
  384.    LVAL prev = NULL ;
  385.    LVAL curr = xlgalist() ;
  386.    LVAL next ;
  387.  
  388.    xllastarg() ;
  389.    if (curr == NIL)
  390.       return NIL ;
  391.    else
  392.       next = cdr(curr) ;
  393.    while (next)
  394.       {
  395.       rplacd(curr,prev) ;
  396.       prev = curr ;
  397.       curr = next ;
  398.       next = cdr(next) ;
  399.       }
  400.    rplacd(curr,prev);
  401.    return curr ;
  402. }
  403.  
  404. /* (every pred arglist ... ) -- return T if pred returns T for every set of args */
  405. LVAL xevery( void )
  406. {
  407.    LVAL pred = xlgetarg() ;
  408.    LVAL p ;
  409.    LVAL result = true ;
  410.    LVAL *argv, *newfp ;
  411.    int argc ;
  412.    int done ;
  413.  
  414.    if (!moreargs())
  415.       return NIL ;
  416.    argv = xlargv ;    /* remember the original parm list */
  417.    argc = xlargc ;
  418.    do {
  419.       xlargv = argv ; /* restore original parm list */
  420.       xlargc = argc ;
  421.       done = FALSE ;
  422.  
  423.       /* build a new argument stack frame */
  424.       newfp = xlsp ;
  425.       pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  426.       pusharg(pred);
  427.       pusharg(cvfixnum((FIXTYPE)argc));
  428.       xlfp = newfp ;
  429.  
  430.       while (moreargs())
  431.          {
  432.          p = xlgalist() ;   /* operate on next arg */
  433.          if (consp(p))
  434.         {
  435.             pusharg(car(p)) ;
  436.             xlargv[-1] = cdr(p) ;
  437.             }
  438.          else
  439.             {
  440.             pusharg(NIL) ;
  441.             done = TRUE ;
  442.             }
  443.          }
  444.    } while (!done && (result = xlapply(argc)) != NIL) ;
  445.    return (result != NIL) ? true : NIL ;
  446. }
  447.  
  448. /* ossymbols - enter os specific symbols */
  449. void ossymbols()
  450. {
  451. }
  452.