src/c/xlisp.c

   1 /* xlisp.c - a small implementation of lisp with object-oriented programming */
   2 /* Copyright (c) 1989, by David Michael Betz.                            */
   3 /* You may give out copies of this software; for conditions see the file */
   4 /* COPYING included with this distribution.                              */
   5
   6 /* For full credits see file xlisp.h */
   7
   8 #include "xlisp.h"
   9
  10 /* define the banner line string */
  11 #define BANNER  "XLISP-PLUS version 3.04\n\
  12 Portions Copyright (c) 1988, by David Betz.\n\
  13 Modified by Thomas Almy and others."
  14
  15 /* global variables */
  16 #ifdef SAVERESTORE
  17 XL_JMP_BUF top_level;
  18 #endif
  19 char *progname;  /* used for reading the symbol table - L. Tierney */
  20 #ifdef SAVERESTORE
  21 char *resfile = "xlisp.wks"; /* make extern to allow setting elsewhere */
  22 #endif
  23
  24 /* local variables */
  25 XL_JMP_BUF exit_xlisp;
  26
  27 /* forward declarations */
  28 #ifdef MACINTOSH
  29 int main(void);
  30 #else
  31 int main _((int argc, char *argv[]));
  32 #endif /* MACINTOSH */
  33 LOCAL VOID toplevelloop(V);
  34
  35 /* main - the main routine */
  36 #ifdef MACINTOSH
  37 int main(void)
  38 #else
  39 int main(argc,argv)
  40      int argc; char *argv[];
  41 #endif /* MACINTOSH */
  42 {
  43     char *transcript;
  44     CONTEXT cntxt;
  45     int verbose,i, sts;
  46     struct { char *transcript; int verbose, i; } state;
  47 #ifdef AMIGA
  48     char project[30],defdir[50];
  49 #endif /* AMIGA */
  50
  51     /* The way out on errors */
  52     i = XL_SETJMP(exit_xlisp);
  53     if (i != 0)
  54         return i-1;
  55
  56     /* setup default argument values */
  57     transcript = NULL;
  58     verbose = FALSE;
  59
  60 #ifdef FILETABLE
  61     /* Initialize the file table values */
  62     filetab[0].fp = stdin;
  63     filetab[0].tname = "(stdin)";
  64     filetab[1].fp = stdout;
  65     filetab[1].tname = "(stdout)";
  66     filetab[2].fp = stderr;
  67     filetab[2].tname = "(console)";
  68     filetab[3].fp = NULL;
  69     filetab[3].tname = "";
  70 #endif
  71
  72     /* parse the argument list switches */
  73 #ifndef MACINTOSH
  74 #ifdef AMIGA
  75     FindStart(&argc,argv,deftool,project,defdir);
  76 #endif /* AMIGA */
  77     progname = argv[0];  /* L. Tierney */
  78     for (i = 1; i < argc; ++i)
  79         if (argv[i][0] == '-')
  80             switch(isupper(argv[i][1])?tolower(argv[i][1]):argv[i][1]) {
  81             case 't':
  82                 transcript = &argv[i][2];
  83                 break;
  84             case 'b':
  85                 batchmode = TRUE;
  86                 break;
  87             case 'v':
  88                 verbose = TRUE;
  89                 break;
  90 #ifdef SAVERESTORE
  91             case 'w':
  92                 resfile = &argv[i][2];
  93                 break;
  94 #endif
  95 #ifdef XLISP_STAT
  96             case 'p':
  97                 defaultpath = &argv[i][2];
  98                 break;
  99 #endif /* XLISP_STAT */
 100 #ifndef _Windows
 101             default: /* Added to print bad switch message */
 102                 fprintf(stderr,"Bad switch: %s\n",argv[i]);
 103 #endif
 104             }
 105 #endif /* MACINTOSH */
 106
 107     /* initialize and print the banner line */
 108     osinit(BANNER);
 109
 110     /* setup initialization error handler */
 111     xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
 112     state.transcript = transcript; state.verbose = verbose; state.i = i;
 113     sts = XL_SETJMP(cntxt.c_jmpbuf);
 114     transcript = state.transcript; verbose = state.verbose; i = state.i;
 115     if (sts)
 116         xlfatal("fatal initialization error");
 117 #ifdef SAVERESTORE
 118     state.transcript = transcript; state.verbose = verbose; state.i = i;
 119     sts = XL_SETJMP(top_level);
 120     transcript = state.transcript; verbose = state.verbose; i = state.i;
 121     if (sts)
 122         xlfatal("RESTORE not allowed during initialization");
 123 #endif
 124
 125     /* initialize xlisp */
 126 #ifdef SAVERESTORE
 127 #ifdef MACINTOSH
 128     i = macxlinit(resfile);
 129 #else
 130     i = xlinit(resfile);
 131 #endif /* MACINTOSH */
 132 #else
 133     i = xlinit(NULL);
 134 #endif
 135
 136     /* reset the error handler, since we know what "true" is */
 137     xlend(&cntxt);
 138     xlbegin(&cntxt, CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL, s_true);
 139
 140     /* open the transcript file */
 141     if (transcript!=NULL && (tfp = OSAOPEN(transcript,CREATE_WR)) == CLOSED) {
 142         /* TAA Mod -- quote name so "-t foo" will indicate no file name */
 143         sprintf(buf,"error: can't open transcript file: \"%s\"",transcript);
 144         stdputstr(buf);
 145     }
 146
 147 #ifndef MACINTOSH
 148     /* enter the command line (L. Tierney 9/93) */
 149     state.transcript = transcript; state.verbose = verbose; state.i = i;
 150     sts = XL_SETJMP(cntxt.c_jmpbuf);
 151     transcript = state.transcript; verbose = state.verbose; i = state.i;
 152     if (sts == 0) {
 153       LVAL line;
 154       int j;
 155       xlsave1(line);
 156       line = NIL;
 157       for (j = argc - 1; j >= 0; j--)
 158         line = cons(cvstring(argv[j]), line);
 159       xlpop();
 160       setsvalue(s_command_line, line);
 161     }
 162 #endif /* MACINTOSH */
 163
 164     enable_interrupts();
 165
 166     /* load "init.lsp" */
 167     if (i) {
 168       state.transcript = transcript; state.verbose = verbose; state.i = i;
 169       sts = XL_SETJMP(cntxt.c_jmpbuf);
 170       transcript = state.transcript; verbose = state.verbose; i = state.i;
 171       if (sts == 0)
 172         xsload("init.lsp",TRUE,FALSE);
 173     }
 174
 175     /* run any startup functions (L. Tierney 9/93) */
 176     state.transcript = transcript; state.verbose = verbose; state.i = i;
 177     sts = XL_SETJMP(cntxt.c_jmpbuf);
 178     transcript = state.transcript; verbose = state.verbose; i = state.i;
 179     if (sts == 0) {
 180       LVAL funs = getvalue(s_startup_functions);
 181       FRAMEP newfp;
 182
 183       for (; consp(funs); funs = cdr(funs)) {
 184         newfp = xlsp;
 185         pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
 186         pusharg(car(funs));
 187         pusharg(cvfixnum((FIXTYPE) 0));
 188         xlfp = newfp;
 189         xlapply(0);
 190       }
 191     }
 192
 193     /* load any files mentioned on the command line */
 194     if (! null(getvalue(s_loadfileargs))) {
 195       state.transcript = transcript; state.verbose = verbose; state.i = i;
 196       sts = XL_SETJMP(cntxt.c_jmpbuf);
 197       transcript = state.transcript; verbose = state.verbose; i = state.i;
 198       if (sts == 0) {
 199 #ifdef MACINTOSH
 200         macloadinits();
 201 #else
 202         for (i = 1; i < argc; i++)
 203             if (argv[i][0] != '-' && !xsload(argv[i],TRUE,verbose))
 204                 xlerror("can't load file",cvstring(argv[i]));
 205 #endif /* MACINTOSH */
 206       }
 207     }
 208
 209     /* target for restore */
 210 #ifdef SAVERESTORE
 211     state.transcript = transcript; state.verbose = verbose; state.i = i;
 212     sts = XL_SETJMP(top_level);
 213     transcript = state.transcript; verbose = state.verbose; i = state.i;
 214     if (sts)
 215         xlbegin(&cntxt, CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL, s_true);
 216 #endif
 217
 218     /* main command processing loop */
 219     for (;;) {
 220
 221         /* setup the error return */
 222         if (XL_SETJMP(cntxt.c_jmpbuf)) {
 223             setvalue(s_evalhook,NIL);
 224             setvalue(s_applyhook,NIL);
 225             xltrcindent = 0;
 226             xldebug = 0;
 227             osreset();   /* L. Tierney */
 228             xlflush();
 229         }
 230
 231 #ifdef STSZ
 232         stackwarn = FALSE;
 233 #endif
 234
 235         if (boundp(s_toplevelloop)) {
 236           FRAMEP newfp;
 237
 238           newfp = xlsp;
 239           pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
 240           pusharg(getvalue(s_toplevelloop));
 241           pusharg(cvfixnum((FIXTYPE) 0));
 242           xlfp = newfp;
 243           xlapply(0);
 244         }
 245         else
 246           toplevelloop();
 247     }   /* never exit from here */
 248 }
 249
 250 /* xtoplevelloop - lisp-callable top level loop */
 251 /* Luke Tierney 9/93 */
 252 LVAL xtoplevelloop(V)
 253 {
 254   xllastarg();
 255
 256   toplevelloop();
 257   return(NIL); /* doesn't return */
 258 }
 259
 260 /* toplevelloop - the default command loop */
 261 LOCAL VOID toplevelloop(V)
 262 {
 263   LVAL expr;
 264 #ifdef MULVALS
 265   int i;
 266 #endif /* MULVALS */
 267
 268   /* protect some pointers */
 269   xlsave1(expr);
 270
 271   for(;;) {
 272     /* print a prompt */
 273 #ifdef PACKAGES
 274     if (!redirectin) {
 275       LVAL pack = getvalue(s_package);
 276       if (pack != xluserpack && goodpackagep(pack)) {
 277         dbgputstr(getstring(xlpackagename(pack)));
 278       }
 279       dbgputstr("> ");
 280     }
 281 #else
 282     if (!redirectin) dbgputstr("> ");
 283 #endif /* PACKAGES */
 284
 285     /* read an expression */
 286     if (!xlread(getvalue(s_stdin),&expr,FALSE,FALSE)) {
 287       /* clean up */
 288       wrapup();
 289       break;
 290     }
 291
 292     /* save the input expression */
 293     xlrdsave(expr);
 294
 295     /* evaluate the expression */
 296     expr = xleval(expr);
 297
 298     /* save the result */
 299     xlevsave(expr);
 300
 301     /* Show result on a new line -- TAA MOD to improve display */
 302     xlfreshline(getvalue(s_stdout));
 303
 304     /* print it */
 305 #ifdef MULVALS
 306     switch (xlnumresults) {
 307     case 0: break;
 308     case 1: stdprint(expr); break;
 309     default:
 310       {
 311         LVAL vals;
 312         xlsave1(vals);
 313         for (i = xlnumresults; i-- > 0; ) vals = cons(xlresults[i], vals);
 314         for (; consp(vals); vals = cdr(vals)) stdprint(car(vals));
 315         xlpop();
 316       }
 317     }
 318 #else
 319     stdprint(expr);
 320 #endif /* MULVALS */
 321   }
 322 }
 323
 324 /* xlrdsave - save the last expression returned by the reader */
 325 VOID xlrdsave P1C(LVAL, expr)
 326 {
 327     setvalue(s_3plus,getvalue(s_2plus));
 328     setvalue(s_2plus,getvalue(s_1plus));
 329     setvalue(s_1plus,getvalue(s_minus));
 330     setvalue(s_minus,expr);
 331 }
 332
 333 /* xlevsave - save the last expression returned by the evaluator */
 334 VOID xlevsave P1C(LVAL, expr)
 335 {
 336     setvalue(s_3star,getvalue(s_2star));
 337     setvalue(s_2star,getvalue(s_1star));
 338     setvalue(s_1star,expr);
 339 }
 340
 341 /* xlfatal - print a fatal error message and exit */
 342 VOID xlfatal P1C(char *, msg)
 343 {
 344     xoserror(msg);
 345     wrapup();
 346 }
 347
 348 /* do-exits - run user exit functions */
 349 VOID do_exits(V)
 350 {
 351   CONTEXT cntxt;
 352
 353   xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,s_true);
 354   XL_SETJMP(cntxt.c_jmpbuf);
 355
 356   while (s_exit_functions != NULL && consp(getvalue(s_exit_functions))) {
 357     FRAMEP newfp;
 358     LVAL func = car(getvalue(s_exit_functions));
 359     setvalue(s_exit_functions, cdr(getvalue(s_exit_functions)));
 360     newfp = xlsp;
 361     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
 362     pusharg(func);
 363     pusharg(cvfixnum((FIXTYPE) 0));
 364     xlfp = newfp;
 365     xlapply(0);
 366   }
 367   xlend(&cntxt);
 368 }
 369
 370 /* wrapup - clean up and exit to the operating system */
 371 VOID wrapup(V)
 372 {
 373   /* $putpatch.c$: "MODULE_XLISP_C_WRAPUP" */
 374   CONTEXT cntxt;
 375
 376   do_exits();
 377   if (XL_SETJMP(cntxt.c_jmpbuf) == 0) {
 378     if (tfp != CLOSED)
 379       OSCLOSE(tfp);
 380     osfinish();
 381   }
 382   XL_LONGJMP(exit_xlisp, 1);
 383 }
 384
 385 /* xresetsystem - reset system for user top-levels */
 386 LVAL xresetsystem(V)
 387 {
 388   osreset();   /* L. Tierney */
 389   xlflush();
 390   return(NIL);
 391 }
 392
 393 /* new internal load function -- allows load to be redefined in workspace */
 394 int xsload P3C(char *, name, int, vflag, int, pflag)
 395 {
 396   if (fboundp(s_load)) {
 397     FRAMEP newfp;
 398
 399     /* create the new call frame */
 400     newfp = xlsp;
 401     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
 402     pusharg(getfunction(s_load));
 403     pusharg(cvfixnum((FIXTYPE) 7));
 404     pusharg(cvstring(name));
 405     pusharg(k_print);
 406     pusharg(pflag ? s_true : NIL);
 407     pusharg(k_verbose);
 408     pusharg(vflag ? s_true : NIL);
 409     pusharg(k_nexist);
 410     pusharg(NIL);
 411     xlfp = newfp;
 412
 413     /* return the result of applying the function */
 414     return null(xlapply(7)) ? FALSE : TRUE;
 415   }
 416   else
 417     return xlload(name, pflag, vflag);
 418 }