home *** CD-ROM | disk | FTP | other *** search
/ Computer Club Elmshorn Atari PD / CCE_PD.iso / pc / 0400 / CCE_0442.ZIP / CCE_0442.PD / XSCHEM28 / XSCHEME.C < prev    next >
C/C++ Source or Header  |  1991-09-16  |  4KB  |  190 lines
  1. /* xscheme.c - xscheme main routine */
  2. /*    Copyright (c) 1990, 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.28"
  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. #ifdef __STDC__
  25. static void usage(void);
  26. #endif
  27.  
  28. /* xlmain - the main routine */
  29. void xlmain(argc,argv)
  30.   int argc; char *argv[];
  31. {
  32.     int src,dst;
  33.     LVAL code;
  34.     char *p;
  35.     
  36.     /* process the arguments */
  37.     for (src = dst = 1, clargv = argv, clargc = 1; src < argc; ++src) {
  38.  
  39.     /* handle options */
  40.     if (argv[src][0] == '-') {
  41.         for (p = &argv[src][1]; *p != '\0'; )
  42.             switch (*p++) {
  43.         case 't':        /* root directory */
  44.             trace = TRUE;
  45.             break;
  46.         default:
  47.                 usage();
  48.         }
  49.     }
  50.  
  51.     /* handle a filename */
  52.     else {
  53.         argv[dst++] = argv[src];
  54.         ++clargc;
  55.     }
  56.     }
  57.  
  58.     /* setup an initialization error handler */
  59.     if (setjmp(top_level))
  60.     exit(1);
  61.  
  62.     /* initialize */
  63.     osinit(BANNER);
  64.     
  65.     /* restore the default workspace, otherwise create a new one */
  66.     if (!xlirestore("xscheme.wks"))
  67.     xlinitws(5000);
  68.  
  69.     /* do the initialization code first */
  70.     code = xlenter("*INITIALIZE*");
  71.     code = (boundp(code) ? getvalue(code) : NIL);
  72.  
  73.     /* trap errors */
  74.     if (setjmp(top_level)) {
  75.     code = xlenter("*TOPLEVEL*");
  76.     code = (boundp(code) ? getvalue(code) : NIL);
  77.     xlfun = xlenv = xlval = NIL;
  78.     xlsp = xlstktop;
  79.     }
  80.  
  81.     /* execute the main loop */
  82.     if (code != NIL)
  83.     xlexecute(code);
  84.     xlwrapup();
  85. }
  86.  
  87. static void usage()
  88. {
  89.     ostputs("usage: xscheme [-t]\n");
  90.     exit(1);
  91. }
  92.  
  93. void xlload() {}
  94. void xlcontinue() {}
  95. void xlbreak() { xltoplevel(); }
  96. void xlcleanup() {}
  97.  
  98. /* xltoplevel - return to the top level */
  99. void xltoplevel()
  100. {
  101.     stdputstr("[ back to top level ]\n");
  102.     longjmp(top_level,1);
  103. }
  104.  
  105. /* xlfail - report an error */
  106. void xlfail(msg)
  107.   char *msg;
  108. {
  109.     xlerror(msg,s_unbound);
  110. }
  111.  
  112. /* xlerror - report an error */
  113. void xlerror(msg,arg)
  114.   char *msg; LVAL arg;
  115. {
  116.     /* display the error message */
  117.     errputstr("Error: ");
  118.     errputstr(msg);
  119.     errputstr("\n");
  120.     
  121.     /* print the argument on a separate line */
  122.     if (arg != s_unbound) {
  123.     errputstr("  ");
  124.     errprint(arg);
  125.     }
  126.     
  127.     /* print the function where the error occurred */
  128.     errputstr("happened in: ");
  129.     errprint(xlfun);
  130.  
  131.     /* call the handler */
  132.     callerrorhandler();
  133. }
  134.  
  135. /* callerrorhandler - call the error handler */
  136. void callerrorhandler()
  137. {
  138.     extern jmp_buf bc_dispatch;
  139.     
  140.     /* invoke the error handler */
  141.     xlval = getvalue(xlenter("*ERROR-HANDLER*"));
  142.     if (xlval != NIL) {
  143.     oscheck();    /* an opportunity to break out of a bad handler */
  144.     check(2);
  145.     push(xlenv);
  146.     push(xlfun);
  147.     xlargc = 2;
  148.     xlapply();
  149.     longjmp(bc_dispatch,1);
  150.     }
  151.  
  152.     /* no handler, just reset back to the top level */
  153.     longjmp(top_level,1);
  154. }
  155.  
  156. /* xlabort - print an error message and abort */
  157. void xlabort(msg)
  158.   char *msg;
  159. {
  160.     /* display the error message */
  161.     errputstr("Abort: ");
  162.     errputstr(msg);
  163.     errputstr("\n");
  164.     
  165.     /* print the function where the error occurred */
  166.     errputstr("happened in: ");
  167.     errprint(xlfun);
  168.  
  169.     /* reset back to the top level */
  170.     oscheck();    /* an opportunity to break out */
  171.     longjmp(top_level,1);
  172. }
  173.  
  174. /* xlfatal - print a fatal error message and exit */
  175. void xlfatal(msg)
  176.   char *msg;
  177. {
  178.     oserror(msg);
  179.     exit(1);
  180. }
  181.  
  182. /* xlwrapup - clean up and exit to the operating system */
  183. void xlwrapup()
  184. {
  185.     if (tfp)
  186.     osclose(tfp);
  187.     osfinish();
  188.     exit(0);
  189. }
  190.