home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / xschm22 / src / xscheme.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-04-18  |  3.8 KB  |  197 lines
  1. /* xscheme.c - xscheme main routine */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* the program banner */
  9. #define BANNER    "XScheme - Version 0.22"
  10.  
  11. /* global variables */
  12. jmp_buf top_level;
  13. int clargc;    /* command line argument count */
  14. char **clargv;    /* array of command line arguments */
  15.  
  16. /* trace file pointer */
  17. FILE *tfp=NULL;
  18.  
  19. /* external variables */
  20. extern LVAL xlfun,xlenv,xlval;
  21. extern LVAL s_stdin,s_stdout,s_stderr,s_unbound;
  22. extern int trace;
  23.  
  24. /* main - the main routine */
  25. main(argc,argv)
  26.   int argc; char *argv[];
  27. {
  28.     int src,dst;
  29.     LVAL code;
  30.     char *p;
  31.     
  32.     /* process the arguments */
  33.     for (src = dst = 1, clargv = argv, clargc = 1; src < argc; ++src) {
  34.  
  35.     /* handle options */
  36.     if (argv[src][0] == '-') {
  37.         for (p = &argv[src][1]; *p != '\0'; )
  38.             switch (*p++) {
  39.         case 't':        /* root directory */
  40.             trace = TRUE;
  41.             break;
  42.         default:
  43.                 usage();
  44.         }
  45.     }
  46.  
  47.     /* handle a filename */
  48.     else {
  49.         argv[dst++] = argv[src];
  50.         ++clargc;
  51.     }
  52.     }
  53.  
  54.     /* setup an initialization error handler */
  55.     if (setjmp(top_level))
  56.     exit(1);
  57.  
  58.     /* initialize */
  59.     osinit(BANNER);
  60.     
  61.     /* restore the default workspace, otherwise create a new one */
  62.     if (!xlirestore("xscheme.wks"))
  63.     xlinitws(5000);
  64.  
  65.     /* do the initialization code first */
  66.     code = xlenter("*INITIALIZE*");
  67.     code = (boundp(code) ? getvalue(code) : NIL);
  68.  
  69.     /* trap errors */
  70.     if (setjmp(top_level)) {
  71.     code = xlenter("*TOPLEVEL*");
  72.     code = (boundp(code) ? getvalue(code) : NIL);
  73.     xlfun = xlenv = xlval = NIL;
  74.     xlsp = xlstktop;
  75.     }
  76.  
  77.     /* execute the main loop */
  78.     if (code != NIL)
  79.     xlexecute(code);
  80.     wrapup();
  81. }
  82.  
  83. usage()
  84. {
  85.     info("usage: xscheme [-t]\n");
  86.     exit(1);
  87. }
  88.  
  89. xlload() {}
  90. xlcontinue() {}
  91. xlbreak() { xltoplevel(); }
  92. xlcleanup() {}
  93.  
  94. /* xltoplevel - return to the top level */
  95. xltoplevel()
  96. {
  97.     stdputstr("[ back to top level ]\n");
  98.     longjmp(top_level,1);
  99. }
  100.  
  101. /* xlfail - report an error */
  102. xlfail(msg)
  103.   char *msg;
  104. {
  105.     xlerror(msg,s_unbound);
  106. }
  107.  
  108. /* xlerror - report an error */
  109. xlerror(msg,arg)
  110.   char *msg; LVAL arg;
  111. {
  112.     /* display the error message */
  113.     errputstr("Error: ");
  114.     errputstr(msg);
  115.     errputstr("\n");
  116.     
  117.     /* print the argument on a separate line */
  118.     if (arg != s_unbound) {
  119.     errputstr("  ");
  120.     errprint(arg);
  121.     }
  122.     
  123.     /* print the function where the error occurred */
  124.     errputstr("happened in: ");
  125.     errprint(xlfun);
  126.  
  127.     /* call the handler */
  128.     callerrorhandler();
  129. }
  130.  
  131. /* callerrorhandler - call the error handler */
  132. callerrorhandler()
  133. {
  134.     extern jmp_buf bc_dispatch;
  135.     
  136.     /* invoke the error handler */
  137.     if (xlval = getvalue(xlenter("*ERROR-HANDLER*"))) {
  138.     oscheck();    /* an opportunity to break out of a bad handler */
  139.     check(2);
  140.     push(xlenv);
  141.     push(xlfun);
  142.     xlargc = 2;
  143.     xlapply();
  144.     longjmp(bc_dispatch,1);
  145.     }
  146.  
  147.     /* no handler, just reset back to the top level */
  148.     longjmp(top_level,1);
  149. }
  150.  
  151. /* xlabort - print an error message and abort */
  152. xlabort(msg)
  153.   char *msg;
  154. {
  155.     /* display the error message */
  156.     errputstr("Abort: ");
  157.     errputstr(msg);
  158.     errputstr("\n");
  159.     
  160.     /* print the function where the error occurred */
  161.     errputstr("happened in: ");
  162.     errprint(xlfun);
  163.  
  164.     /* reset back to the top level */
  165.     oscheck();    /* an opportunity to break out */
  166.     longjmp(top_level,1);
  167. }
  168.  
  169. /* xlfatal - print a fatal error message and exit */
  170. xlfatal(fmt,a1,a2,a3,a4)
  171.   char *fmt;
  172. {
  173.     char buf[100];
  174.     sprintf(buf,fmt,a1,a2,a3,a4);
  175.     oserror(buf);
  176.     exit(1);
  177. }
  178.  
  179. /* info - display debugging information */
  180. info(fmt,a1,a2,a3,a4)
  181.   char *fmt;
  182. {
  183.     char buf[100],*p;
  184.     sprintf(buf,fmt,a1,a2,a3,a4);
  185.     for (p = buf; *p != '\0'; )
  186.     ostputc(*p++);
  187. }
  188.  
  189. /* wrapup - clean up and exit to the operating system */
  190. wrapup()
  191. {
  192.     if (tfp)
  193.     osclose(tfp);
  194.     osfinish();
  195.     exit(0);
  196. }
  197.