home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / 32XLISP.ZIP / XLISP.C < prev    next >
Text File  |  1989-04-23  |  4KB  |  168 lines
  1. /* xlisp.c - a small implementation of lisp with object-oriented programming */
  2. /*    Copyright (c) 1987, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* define the banner line string */
  9. #define BANNER    "XLISP version 2.1, Copyright (c) 1989, by David Betz"
  10.  
  11. /* global variables */
  12. jmp_buf top_level;
  13.  
  14. /* external variables */
  15. extern LVAL s_stdin,s_evalhook,s_applyhook;
  16. extern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
  17. extern int xltrcindent;
  18. extern int xldebug;
  19. extern LVAL true;
  20. extern char buf[];
  21. extern FILE *tfp;
  22.  
  23. /* external routines */
  24. extern FILE *osaopen();
  25.  
  26. /* main - the main routine */
  27. main(argc,argv)
  28.   int argc; char *argv[];
  29. {
  30.     char *transcript;
  31.     CONTEXT cntxt;
  32.     int verbose,i;
  33.     LVAL expr;
  34.  
  35.     /* setup default argument values */
  36.     transcript = NULL;
  37.     verbose = FALSE;
  38.  
  39.     /* parse the argument list switches */
  40. #ifndef LSC
  41.     for (i = 1; i < argc; ++i)
  42.     if (argv[i][0] == '-')
  43.         switch(argv[i][1]) {
  44.         case 't':
  45.         case 'T':
  46.         transcript = &argv[i][2];
  47.         break;
  48.         case 'v':
  49.         case 'V':
  50.         verbose = TRUE;
  51.         break;
  52.         }
  53. #endif
  54.  
  55.     /* initialize and print the banner line */
  56.     osinit(BANNER);
  57.  
  58.     /* setup initialization error handler */
  59.     xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
  60.     if (setjmp(cntxt.c_jmpbuf))
  61.     xlfatal("fatal initialization error");
  62.     if (setjmp(top_level))
  63.     xlfatal("RESTORE not allowed during initialization");
  64.  
  65.     /* initialize xlisp */
  66.     xlinit();
  67.     xlend(&cntxt);
  68.  
  69.     /* reset the error handler */
  70.     xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
  71.  
  72.     /* open the transcript file */
  73.     if (transcript && (tfp = osaopen(transcript,"w")) == NULL) {
  74.     sprintf(buf,"error: can't open transcript file: %s",transcript);
  75.     stdputstr(buf);
  76.     }
  77.  
  78.     /* load "init.lsp" */
  79.     if (setjmp(cntxt.c_jmpbuf) == 0)
  80.     xlload("init.lsp",TRUE,FALSE);
  81.  
  82.     /* load any files mentioned on the command line */
  83.     if (setjmp(cntxt.c_jmpbuf) == 0)
  84.     for (i = 1; i < argc; i++)
  85.         if (argv[i][0] != '-' && !xlload(argv[i],TRUE,verbose))
  86.         xlerror("can't load file",cvstring(argv[i]));
  87.  
  88.     /* target for restore */
  89.     if (setjmp(top_level))
  90.     xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
  91.  
  92.     /* protect some pointers */
  93.     xlsave1(expr);
  94.  
  95.     /* main command processing loop */
  96.     for (;;) {
  97.  
  98.     /* setup the error return */
  99.     if (setjmp(cntxt.c_jmpbuf)) {
  100.         setvalue(s_evalhook,NIL);
  101.         setvalue(s_applyhook,NIL);
  102.         xltrcindent = 0;
  103.         xldebug = 0;
  104.         xlflush();
  105.     }
  106.  
  107.     /* print a prompt */
  108.     stdputstr("> ");
  109.  
  110.     /* read an expression */
  111.     if (!xlread(getvalue(s_stdin),&expr,FALSE))
  112.         break;
  113.  
  114.     /* save the input expression */
  115.     xlrdsave(expr);
  116.  
  117.     /* evaluate the expression */
  118.     expr = xleval(expr);
  119.  
  120.     /* save the result */
  121.     xlevsave(expr);
  122.  
  123.     /* print it */
  124.     stdprint(expr);
  125.     }
  126.     xlend(&cntxt);
  127.  
  128.     /* clean up */
  129.     wrapup();
  130. }
  131.  
  132. /* xlrdsave - save the last expression returned by the reader */
  133. xlrdsave(expr)
  134.   LVAL expr;
  135. {
  136.     setvalue(s_3plus,getvalue(s_2plus));
  137.     setvalue(s_2plus,getvalue(s_1plus));
  138.     setvalue(s_1plus,getvalue(s_minus));
  139.     setvalue(s_minus,expr);
  140. }
  141.  
  142. /* xlevsave - save the last expression returned by the evaluator */
  143. xlevsave(expr)
  144.   LVAL expr;
  145. {
  146.     setvalue(s_3star,getvalue(s_2star));
  147.     setvalue(s_2star,getvalue(s_1star));
  148.     setvalue(s_1star,expr);
  149. }
  150.  
  151. /* xlfatal - print a fatal error message and exit */
  152. xlfatal(msg)
  153.   char *msg;
  154. {
  155.     oserror(msg);
  156.     wrapup();
  157. }
  158.  
  159. /* wrapup - clean up and exit to the operating system */
  160. wrapup()
  161. {
  162.     if (tfp)
  163.     osclose(tfp);
  164.     osfinish();
  165.     exit(0);
  166. }
  167.  
  168.