ghc/interpreter/hugs.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Command interpreter
   4  *
   5  * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
   6  * Haskell Group 1994-99, and is distributed as Open Source software
   7  * under the Artistic License; see the file "Artistic" that is included
   8  * in the distribution for details.
   9  *
  10  * $RCSfile: hugs.c,v $
  11  * $Revision: 1.7 $
  12  * $Date: 1999/06/07 17:22:43 $
  13  * ------------------------------------------------------------------------*/
  14
  15 #include <setjmp.h>
  16 #include <ctype.h>
  17 #include <stdio.h>
  18
  19 #include "prelude.h"
  20 #include "storage.h"
  21 #include "command.h"
  22 #include "backend.h"
  23 #include "connect.h"
  24 #include "errors.h"
  25 #include "version.h"
  26 #include "link.h"
  27
  28 #include "Rts.h"
  29 #include "RtsAPI.h"
  30 #include "Schedule.h"
  31
  32
  33 Bool haskell98 = TRUE;                  /* TRUE => Haskell 98 compatibility*/
  34
  35 /* --------------------------------------------------------------------------
  36  * Local function prototypes:
  37  * ------------------------------------------------------------------------*/
  38
  39 static Void   local initialize        Args((Int,String []));
  40 static Void   local promptForInput    Args((String));
  41 static Void   local interpreter       Args((Int,String []));
  42 static Void   local menu              Args((Void));
  43 static Void   local guidance          Args((Void));
  44 static Void   local forHelp           Args((Void));
  45 static Void   local set               Args((Void));
  46 static Void   local changeDir         Args((Void));
  47 static Void   local load              Args((Void));
  48 static Void   local project           Args((Void));
  49 static Void   local readScripts       Args((Int));
  50 static Void   local whatScripts       Args((Void));
  51 static Void   local editor            Args((Void));
  52 static Void   local find              Args((Void));
  53 static Bool   local startEdit         Args((Int,String));
  54 static Void   local runEditor         Args((Void));
  55 static Void   local setModule         Args((Void));
  56 static Module local findEvalModule    Args((Void));
  57 static Void   local evaluator         Args((Void));
  58 static Void   local stopAnyPrinting   Args((Void));
  59 static Void   local showtype          Args((Void));
  60 static String local objToStr          Args((Module, Cell));
  61 static Void   local info              Args((Void));
  62 static Void   local printSyntax       Args((Name));
  63 static Void   local showInst          Args((Inst));
  64 static Void   local describe          Args((Text));
  65 static Void   local listNames         Args((Void));
  66
  67 static Void   local toggleSet         Args((Char,Bool));
  68 static Void   local togglesIn         Args((Bool));
  69 static Void   local optionInfo        Args((Void));
  70 #if USE_REGISTRY || HUGS_FOR_WINDOWS
  71 static String local optionsToStr      Args((Void));
  72 #endif
  73 static Void   local readOptions       Args((String));
  74 static Bool   local processOption     Args((String));
  75 static Void   local setHeapSize       Args((String));
  76 static Int    local argToInt          Args((String));
  77
  78 static Void   local loadProject       Args((String));
  79 static Void   local clearProject      Args((Void));
  80 static Bool   local addScript         Args((Int));
  81 static Void   local forgetScriptsFrom Args((Script));
  82 static Void   local setLastEdit       Args((String,Int));
  83 static Void   local failed            Args((Void));
  84 static String local strCopy           Args((String));
  85
  86
  87 /* --------------------------------------------------------------------------
  88  * Machine dependent code for Hugs interpreter:
  89  * ------------------------------------------------------------------------*/
  90
  91 #include "machdep.c"
  92 #ifdef WANT_TIMER
  93 #include "timer.c"
  94 #endif
  95
  96 /* --------------------------------------------------------------------------
  97  * Local data areas:
  98  * ------------------------------------------------------------------------*/
  99
 100 static Bool   printing     = FALSE;     /* TRUE => currently printing value*/
 101 static Bool   showStats    = FALSE;     /* TRUE => print stats after eval  */
 102 static Bool   listScripts  = TRUE;      /* TRUE => list scripts after loading*/
 103 static Bool   addType      = FALSE;     /* TRUE => print type with value   */
 104 static Bool   useDots      = RISCOS;    /* TRUE => use dots in progress    */
 105 static Bool   quiet        = FALSE;     /* TRUE => don't show progress     */
 106        Bool   preludeLoaded = FALSE;
 107        Bool   optimise      = FALSE;
 108
 109 typedef
 110    struct {
 111       String modName;                   /* Module name                     */
 112       Bool   details;             /* FALSE => remaining fields are invalid */
 113       String path;                      /* Path to module                  */
 114       String srcExt;                    /* ".hs" or ".lhs" if fromSource   */
 115       Time   lastChange;                /* Time of last change to script   */
 116       Bool   fromSource;                /* FALSE => load object code       */
 117       Bool   postponed;                 /* Indicates postponed load        */
 118       Bool   objLoaded;
 119       Long   size;
 120       Long   oSize;
 121    }
 122    ScriptInfo;
 123
 124 static Void   local makeStackEntry    Args((ScriptInfo*,String));
 125 static Void   local addStackEntry     Args((String));
 126
 127 static ScriptInfo scriptInfo[NUM_SCRIPTS];
 128
 129 static Int    numScripts;               /* Number of scripts loaded        */
 130 static Int    nextNumScripts;
 131 static Int    namesUpto;                /* Number of script names set      */
 132 static Bool   needsImports;             /* set to TRUE if imports required */
 133        String scriptFile;               /* Name of current script (if any) */
 134
 135
 136
 137 static Text   evalModule  = 0;          /* Name of module we eval exprs in */
 138 static String currProject = 0;          /* Name of current project file    */
 139 static Bool   projectLoaded = FALSE;    /* TRUE => project file loaded     */
 140
 141 static Bool   autoMain   = FALSE;
 142 static String lastEdit   = 0;           /* Name of script to edit (if any) */
 143 static Int    lastEdLine = 0;           /* Editor line number (if possible)*/
 144 static String prompt     = 0;           /* Prompt string                   */
 145 static Int    hpSize     = DEFAULTHEAP; /* Desired heap size               */
 146        String hugsEdit   = 0;           /* String for editor command       */
 147        String hugsPath   = 0;           /* String for file search path     */
 148
 149 #if REDIRECT_OUTPUT
 150 static Bool disableOutput = FALSE;      /* redirect output to buffer?      */
 151 #endif
 152
 153 String bool2str ( Bool b )
 154 {
 155    if (b) return "Yes"; else return "No ";
 156 }
 157
 158 void ppSmStack ( String who )
 159 {
 160    int i, j;
 161    fflush(stdout);fflush(stderr);
 162    printf ( "\n" );
 163    printf ( "ppSmStack %s:  numScripts = %d   namesUpto = %d  needsImports = %s\n",
 164             who, numScripts, namesUpto, bool2str(needsImports) );
 165    assert (namesUpto >= numScripts);
 166    printf ( "     Det FrS Pst ObL           Module Ext   Size ModTime  Path\n" );
 167    for (i = namesUpto-1; i >= 0; i--) {
 168       printf ( "%c%2d: %3s %3s %3s %3s %16s %-4s %5ld %8lx %s\n",
 169                (i==numScripts ? '*' : ' '),
 170                i, bool2str(scriptInfo[i].details),
 171                   bool2str(scriptInfo[i].fromSource),
 172                   bool2str(scriptInfo[i].postponed),
 173                   bool2str(scriptInfo[i].objLoaded),
 174                   scriptInfo[i].modName,
 175                   scriptInfo[i].fromSource ? scriptInfo[i].srcExt : "",
 176                   scriptInfo[i].size,
 177                   scriptInfo[i].lastChange,
 178                   scriptInfo[i].path
 179              );
 180    }
 181    //   printf ( "\n" );
 182    fflush(stdout);fflush(stderr);
 183 ppScripts();
 184 ppModules();
 185    printf ( "\n" );
 186 }
 187
 188 /* --------------------------------------------------------------------------
 189  * Hugs entry point:
 190  * ------------------------------------------------------------------------*/
 191
 192 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
 193
 194 Main main Args((Int, String []));       /* now every func has a prototype  */
 195
 196 Main main(argc,argv)
 197 int  argc;
 198 char *argv[]; {
 199 #ifdef HAVE_CONSOLE_H /* Macintosh port */
 200     _ftype = 'TEXT';
 201     _fcreator = 'R*ch';       /*  // 'KAHL';      //'*TEX';       //'ttxt'; */
 202
 203     console_options.top = 50;
 204     console_options.left = 20;
 205
 206     console_options.nrows = 32;
 207     console_options.ncols = 80;
 208
 209     console_options.pause_atexit = 1;
 210     console_options.title = "\pHugs";
 211
 212     console_options.procID = 5;
 213     argc = ccommand(&argv);
 214 #endif
 215
 216     CStackBase = &argc;                 /* Save stack base for use in gc   */
 217
 218     /* If first arg is +Q or -Q, be entirely silent, and automatically run
 219        main after loading scripts.  Useful for running the nofib suite.    */
 220     if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
 221        autoMain = TRUE;
 222        hugsEnableOutput(0);
 223     }
 224
 225     Printf("__   __ __  __  ____   ___     _______________________________________________\n");
 226     Printf("||   || ||  || ||  || ||__     Hugs 98: The Nottingham and Yale Haskell system\n");
 227     Printf("||___|| ||__|| ||__||  __||    Copyright (c) 1994-1999\n");
 228     Printf("||---||         ___||          World Wide Web: http://haskell.org/hugs\n");
 229     Printf("||   ||                        Report bugs to: hugs-bugs@haskell.org\n");
 230     Printf("||   || Version: %s _______________________________________________\n\n",HUGS_VERSION);
 231
 232 #if SYMANTEC_C
 233     Printf("   Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
 234 #endif
 235     FlushStdout();
 236     interpreter(argc,argv);
 237     Printf("[Leaving Hugs]\n");
 238     everybody(EXIT);
 239     shutdownHaskell();
 240     FlushStdout();
 241     fflush(stderr);
 242     exit(0);
 243     MainDone();
 244 }
 245
 246 #endif
 247
 248 /* --------------------------------------------------------------------------
 249  * Initialization, interpret command line args and read prelude:
 250  * ------------------------------------------------------------------------*/
 251
 252 static Void local initialize(argc,argv)/* Interpreter initialization       */
 253 Int    argc;
 254 String argv[]; {
 255     Script i;
 256     String proj        = 0;
 257     char argv_0_orig[1000];
 258
 259     setLastEdit((String)0,0);
 260     lastEdit      = 0;
 261     scriptFile    = 0;
 262     numScripts    = 0;
 263     namesUpto     = 1;
 264
 265 #if HUGS_FOR_WINDOWS
 266     hugsEdit      = strCopy(fromEnv("EDITOR","c:\\windows\notepad.exe"));
 267 #elif SYMANTEC_C
 268     hugsEdit      = "";
 269 #else
 270     hugsEdit      = strCopy(fromEnv("EDITOR",NULL));
 271 #endif
 272     hugsPath      = strCopy(HUGSPATH); readOptions("-p\"%s> \" -r$$");
 273 #if USE_REGISTRY
 274     projectPath   = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
 275                                                 "HUGSPATH", PATHSEP, ""));
 276     readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
 277     readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
 278 #endif /* USE_REGISTRY */
 279     readOptions(fromEnv("STGHUGSFLAGS",""));
 280
 281    strncpy(argv_0_orig,argv[0],1000);   /* startupHaskell mangles argv[0] */
 282    startupHaskell (argc,argv);
 283    argc = prog_argc; argv = prog_argv;
 284
 285     namesUpto = numScripts = 0;
 286     addStackEntry("Prelude");
 287
 288    for (i=1; i<argc; ++i) {            /* process command line arguments  */
 289         if (strcmp(argv[i], "--")==0) break;
 290         if (strcmp(argv[i],"+")==0 && i+1<argc) {
 291             if (proj) {
 292                 ERRMSG(0) "Multiple project filenames on command line"
 293                 EEND;
 294             } else {
 295                 proj = argv[++i];
 296             }
 297         } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
 298                  && !processOption(argv[i])) {
 299             addStackEntry(argv[i]);
 300         }
 301     }
 302
 303 #ifdef DEBUG
 304     DEBUG_LoadSymbols(argv_0_orig);
 305 #endif
 306
 307
 308
 309 #if 0
 310     if (!scriptName[0]) {
 311         Printf("Prelude not found on current path: \"%s\"\n",
 312                hugsPath ? hugsPath : "");
 313         fatal("Unable to load prelude");
 314     }
 315 #endif
 316
 317     if (haskell98) {
 318         Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n\n");
 319     } else {
 320         Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n\n");
 321     }
 322
 323     everybody(INSTALL);
 324     evalModule = findText("");      /* evaluate wrt last module by default */
 325     if (proj) {
 326         if (namesUpto>1) {
 327             fprintf(stderr,
 328                     "\nUsing project file, ignoring additional filenames\n");
 329         }
 330         loadProject(strCopy(proj));
 331     }
 332     readScripts(0);
 333 }
 334
 335 /* --------------------------------------------------------------------------
 336  * Command line options:
 337  * ------------------------------------------------------------------------*/
 338
 339 struct options {                        /* command line option toggles     */
 340     char   c;                           /* table defined in main app.      */
 341     String description;
 342     Bool   *flag;
 343 };
 344 extern struct options toggle[];
 345
 346 static Void local toggleSet(c,state)    /* Set command line toggle         */
 347 Char c;
 348 Bool state; {
 349     Int i;
 350     for (i=0; toggle[i].c; ++i)
 351         if (toggle[i].c == c) {
 352             *toggle[i].flag = state;
 353             return;
 354         }
 355     ERRMSG(0) "Unknown toggle `%c'", c
 356     EEND;
 357 }
 358
 359 static Void local togglesIn(state)      /* Print current list of toggles in*/
 360 Bool state; {                           /* given state                     */
 361     Int count = 0;
 362     Int i;
 363     for (i=0; toggle[i].c; ++i)
 364         if (*toggle[i].flag == state) {
 365             if (count==0)
 366                 Putchar((char)(state ? '+' : '-'));
 367             Putchar(toggle[i].c);
 368             count++;
 369         }
 370     if (count>0)
 371         Putchar(' ');
 372 }
 373
 374 static Void local optionInfo() {        /* Print information about command */
 375     static String fmts = "%-5s%s\n";    /* line settings                   */
 376     static String fmtc = "%-5c%s\n";
 377     Int    i;
 378
 379     Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
 380     for (i=0; toggle[i].c; ++i)
 381         Printf(fmtc,toggle[i].c,toggle[i].description);
 382
 383     Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
 384     Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
 385     Printf(fmts,"pstr","Set prompt string to str");
 386     Printf(fmts,"rstr","Set repeat last expression string to str");
 387     Printf(fmts,"Pstr","Set search path for modules to str");
 388     Printf(fmts,"Estr","Use editor setting given by str");
 389     Printf(fmts,"cnum","Set constraint cutoff limit");
 390 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 391     Printf(fmts,"Fstr","Set preprocessor filter to str");
 392 #endif
 393
 394     Printf("\nCurrent settings: ");
 395     togglesIn(TRUE);
 396     togglesIn(FALSE);
 397     Printf("-h%d",heapSize);
 398     Printf(" -p");
 399     printString(prompt);
 400     Printf(" -r");
 401     printString(repeatStr);
 402     Printf(" -c%d",cutoff);
 403     Printf("\nSearch path     : -P");
 404     printString(hugsPath);
 405 #if 0
 406 ToDo
 407     if (projectPath!=NULL) {
 408         Printf("\nProject Path    : %s",projectPath);
 409     }
 410 #endif
 411     Printf("\nEditor setting  : -E");
 412     printString(hugsEdit);
 413 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 414     Printf("\nPreprocessor    : -F");
 415     printString(preprocessor);
 416 #endif
 417     Printf("\nCompatibility   : %s", haskell98 ? "Haskell 98"
 418                                                : "Hugs Extensions");
 419     Putchar('\n');
 420 }
 421
 422 #if USE_REGISTRY || HUGS_FOR_WINDOWS
 423 #define PUTC(c)                         \
 424     *next++=(c)
 425
 426 #define PUTS(s)                         \
 427     strcpy(next,s);                     \
 428     next+=strlen(next)
 429
 430 #define PUTInt(optc,i)                  \
 431     sprintf(next,"-%c%d",optc,i);       \
 432     next+=strlen(next)
 433
 434 #define PUTStr(c,s)                     \
 435     next=PUTStr_aux(next,c,s)
 436
 437 static String local PUTStr_aux Args((String,Char, String));
 438
 439 static String local PUTStr_aux(next,c,s)
 440 String next;
 441 Char   c;
 442 String s; {
 443     if (s) {
 444         String t = 0;
 445         sprintf(next,"-%c\"",c);
 446         next+=strlen(next);
 447         for(t=s; *t; ++t) {
 448             PUTS(unlexChar(*t,'"'));
 449         }
 450         next+=strlen(next);
 451         PUTS("\" ");
 452     }
 453     return next;
 454 }
 455
 456 static String local optionsToStr() {          /* convert options to string */
 457     static char buffer[2000];
 458     String next = buffer;
 459
 460     Int i;
 461     for (i=0; toggle[i].c; ++i) {
 462         PUTC(*toggle[i].flag ? '+' : '-');
 463         PUTC(toggle[i].c);
 464         PUTC(' ');
 465     }
 466     PUTInt('h',hpSize);  PUTC(' ');
 467     PUTStr('p',prompt);
 468     PUTStr('r',repeatStr);
 469     PUTStr('P',hugsPath);
 470     PUTStr('E',hugsEdit);
 471     PUTInt('c',cutoff);  PUTC(' ');
 472 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 473     PUTStr('F',preprocessor);
 474 #endif
 475     PUTC('\0');
 476     return buffer;
 477 }
 478 #endif /* USE_REGISTRY */
 479
 480 #undef PUTC
 481 #undef PUTS
 482 #undef PUTInt
 483 #undef PUTStr
 484
 485 static Void local readOptions(options)         /* read options from string */
 486 String options; {
 487     String s;
 488     if (options) {
 489         stringInput(options);
 490         while ((s=readFilename())!=0) {
 491             if (*s && !processOption(s)) {
 492                 ERRMSG(0) "Option string must begin with `+' or `-'"
 493                 EEND;
 494             }
 495         }
 496     }
 497 }
 498
 499 static Bool local processOption(s)      /* process string s for options,   */
 500 String s; {                             /* return FALSE if none found.     */
 501     Bool state;
 502
 503     if (s[0]=='-')
 504         state = FALSE;
 505     else if (s[0]=='+')
 506         state = TRUE;
 507     else
 508         return FALSE;
 509
 510     while (*++s)
 511         switch (*s) {
 512             case 'Q' : break;                           /* already handled */
 513
 514             case 'p' : if (s[1]) {
 515                            if (prompt) free(prompt);
 516                            prompt = strCopy(s+1);
 517                        }
 518                        return TRUE;
 519
 520             case 'r' : if (s[1]) {
 521                            if (repeatStr) free(repeatStr);
 522                            repeatStr = strCopy(s+1);
 523                        }
 524                        return TRUE;
 525
 526             case 'P' : {
 527                            String p = substPath(s+1,hugsPath ? hugsPath : "");
 528                            if (hugsPath) free(hugsPath);
 529                            hugsPath = p;
 530                            return TRUE;
 531                        }
 532
 533             case 'E' : if (hugsEdit) free(hugsEdit);
 534                        hugsEdit = strCopy(s+1);
 535                        return TRUE;
 536
 537 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 538             case 'F' : if (preprocessor) free(preprocessor);
 539                        preprocessor = strCopy(s+1);
 540                        return TRUE;
 541 #endif
 542
 543             case 'h' : setHeapSize(s+1);
 544                        return TRUE;
 545
 546             case 'D' : /* hack */
 547                 {
 548                     extern void setRtsFlags( int x );
 549                     setRtsFlags(argToInt(s+1));
 550                     return TRUE;
 551                 }
 552
 553             default  : if (strcmp("98",s)==0) {
 554                            if (heapBuilt() && ((state && !haskell98) ||
 555                                                (!state && haskell98))) {
 556                                FPrintf(stderr,"Haskell 98 compatibility cannot be changed while the interpreter is running\n");
 557                            } else {
 558                                haskell98 = state;
 559                            }
 560                            return TRUE;
 561                        } else {
 562                            toggleSet(*s,state);
 563                        }
 564                        break;
 565         }
 566     return TRUE;
 567 }
 568
 569 static Void local setHeapSize(s)
 570 String s; {
 571     if (s) {
 572         hpSize = argToInt(s);
 573         if (hpSize < MINIMUMHEAP)
 574             hpSize = MINIMUMHEAP;
 575         else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
 576             hpSize = MAXIMUMHEAP;
 577         if (heapBuilt() && hpSize != heapSize) {
 578             /* ToDo: should this use a message box in winhugs? */
 579 #if USE_REGISTRY
 580             FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
 581 #else
 582             FPrintf(stderr,"Cannot change heap size\n");
 583 #endif
 584         } else {
 585             heapSize = hpSize;
 586         }
 587     }
 588 }
 589
 590 static Int local argToInt(s)            /* read integer from argument str  */
 591 String s; {
 592     Int    n = 0;
 593     String t = s;
 594
 595     if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
 596         ERRMSG(0) "Missing integer in option setting \"%s\"", t
 597         EEND;
 598     }
 599
 600     do {
 601         Int d = (*s++) - '0';
 602         if (n > ((MAXPOSINT - d)/10)) {
 603             ERRMSG(0) "Option setting \"%s\" is too large", t
 604             EEND;
 605         }
 606         n     = 10*n + d;
 607     } while (isascii((int)(*s)) && isdigit((int)(*s)));
 608
 609     if (*s=='K' || *s=='k') {
 610         if (n > (MAXPOSINT/1000)) {
 611             ERRMSG(0) "Option setting \"%s\" is too large", t
 612             EEND;
 613         }
 614         n *= 1000;
 615         s++;
 616     }
 617
 618 #if MAXPOSINT > 1000000                 /* waste of time on 16 bit systems */
 619     if (*s=='M' || *s=='m') {
 620         if (n > (MAXPOSINT/1000000)) {
 621             ERRMSG(0) "Option setting \"%s\" is too large", t
 622             EEND;
 623         }
 624         n *= 1000000;
 625         s++;
 626     }
 627 #endif
 628
 629 #if MAXPOSINT > 1000000000
 630     if (*s=='G' || *s=='g') {
 631         if (n > (MAXPOSINT/1000000000)) {
 632             ERRMSG(0) "Option setting \"%s\" is too large", t
 633             EEND;
 634         }
 635         n *= 1000000000;
 636         s++;
 637     }
 638 #endif
 639
 640     if (*s!='\0') {
 641         ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
 642         EEND;
 643     }
 644
 645     return n;
 646 }
 647
 648 /* --------------------------------------------------------------------------
 649  * Print Menu of list of commands:
 650  * ------------------------------------------------------------------------*/
 651
 652 static struct cmd cmds[] = {
 653  {":?",      HELP},   {":cd",   CHGDIR},  {":also",    ALSO},
 654  {":type",   TYPEOF}, {":!",    SYSTEM},  {":load",    LOAD},
 655  {":reload", RELOAD}, {":gc",   COLLECT}, {":edit",    EDIT},
 656  {":quit",   QUIT},   {":set",  SET},     {":find",    FIND},
 657  {":names",  NAMES},  {":info", INFO},    {":project", PROJECT},
 658  {":dump",   DUMP},   {":ztats", STATS},
 659  {":module",SETMODULE},
 660  {"",      EVAL},
 661  {0,0}
 662 };
 663
 664 static Void local menu() {
 665     Printf("LIST OF COMMANDS:  Any command may be abbreviated to :c where\n");
 666     Printf("c is the first character in the full name.\n\n");
 667     Printf(":load <filenames>   load modules from specified files\n");
 668     Printf(":load               clear all files except prelude\n");
 669     Printf(":also <filenames>   read additional modules\n");
 670     Printf(":reload             repeat last load command\n");
 671     Printf(":project <filename> use project file\n");
 672     Printf(":edit <filename>    edit file\n");
 673     Printf(":edit               edit last module\n");
 674     Printf(":module <module>    set module for evaluating expressions\n");
 675     Printf("<expr>              evaluate expression\n");
 676     Printf(":type <expr>        print type of expression\n");
 677     Printf(":?                  display this list of commands\n");
 678     Printf(":set <options>      set command line options\n");
 679     Printf(":set                help on command line options\n");
 680     Printf(":names [pat]        list names currently in scope\n");
 681     Printf(":info <names>       describe named objects\n");
 682     Printf(":find <name>        edit module containing definition of name\n");
 683     Printf(":!command           shell escape\n");
 684     Printf(":cd dir             change directory\n");
 685     Printf(":gc                 force garbage collection\n");
 686     Printf(":dump <name>        print STG code for named fn\n");
 687 #ifdef CRUDE_PROFILING
 688     Printf(":ztats <name>       print reduction stats\n");
 689 #endif
 690     Printf(":quit               exit Hugs interpreter\n");
 691 }
 692
 693 static Void local guidance() {
 694     Printf("Command not recognised.  ");
 695     forHelp();
 696 }
 697
 698 static Void local forHelp() {
 699     Printf("Type :? for help\n");
 700 }
 701
 702 /* --------------------------------------------------------------------------
 703  * Setting of command line options:
 704  * ------------------------------------------------------------------------*/
 705
 706 struct options toggle[] = {             /* List of command line toggles    */
 707     {'s', "Print no. reductions/cells after eval", &showStats},
 708     {'t', "Print type after evaluation",           &addType},
 709     /*ToDo??    {'f', "Terminate evaluation on first error",   &failOnError},*/
 710     {'g', "Print no. cells recovered after gc",    &gcMessages},
 711     {'l', "Literate modules as default",           &literateScripts},
 712     {'e', "Warn about errors in literate modules", &literateErrors},
 713     {'.', "Print dots to show progress",           &useDots},
 714     {'q', "Print nothing to show progress",        &quiet},
 715     {'w', "Always show which modules are loaded",  &listScripts},
 716     {'k', "Show kind errors in full",              &kindExpert},
 717     {'o', "Allow overlapping instances",           &allowOverlap},
 718     {'O', "Optimise (improve?) generated code",    &optimise},
 719 #if DEBUG_CODE
 720     {'D', "Debug: show generated code",            &debugCode},
 721 #endif
 722     {0,   0,                                       0}
 723 };
 724
 725 static Void local set() {               /* change command line options from*/
 726     String s;                           /* Hugs command line               */
 727
 728     if ((s=readFilename())!=0) {
 729         do {
 730             if (!processOption(s)) {
 731                 ERRMSG(0) "Option string must begin with `+' or `-'"
 732                 EEND;
 733             }
 734         } while ((s=readFilename())!=0);
 735 #if USE_REGISTRY
 736         writeRegString("Options", optionsToStr());
 737 #endif
 738     }
 739     else
 740         optionInfo();
 741 }
 742
 743 /* --------------------------------------------------------------------------
 744  * Change directory command:
 745  * ------------------------------------------------------------------------*/
 746
 747 static Void local changeDir() {         /* change directory                */
 748     String s = readFilename();
 749     if (s && chdir(s)) {
 750         ERRMSG(0) "Unable to change to directory \"%s\"", s
 751         EEND;
 752     }
 753 }
 754
 755 /* --------------------------------------------------------------------------
 756  * Loading project and script files:
 757  * ------------------------------------------------------------------------*/
 758
 759 static Void local loadProject(s)        /* Load project file               */
 760 String s; {
 761     clearProject();
 762     currProject = s;
 763     projInput(currProject);
 764     scriptFile = currProject;
 765     forgetScriptsFrom(1);
 766     while ((s=readFilename())!=0)
 767         addStackEntry(s);
 768     if (namesUpto<=1) {
 769         ERRMSG(0) "Empty project file"
 770         EEND;
 771     }
 772     scriptFile    = 0;
 773     projectLoaded = TRUE;
 774 }
 775
 776 static Void local clearProject() {      /* clear name for current project  */
 777     if (currProject)
 778         free(currProject);
 779     currProject   = 0;
 780     projectLoaded = FALSE;
 781 #if HUGS_FOR_WINDOWS
 782     setLastEdit((String)0,0);
 783 #endif
 784 }
 785
 786
 787
 788 static Void local makeStackEntry ( ScriptInfo* ent, String iname )
 789 {
 790    Bool   ok, fromObj;
 791    Bool   sAvail, iAvail, oAvail;
 792    Time   sTime,  iTime,  oTime;
 793    Long   sSize,  iSize,  oSize;
 794    String path,   sExt;
 795
 796    ok = findFilesForModule (
 797            iname,
 798            &path,
 799            &sExt,
 800            &sAvail, &sTime, &sSize,
 801            &iAvail, &iTime, &iSize,
 802            &oAvail, &oTime, &oSize
 803         );
 804    if (!ok) {
 805       ERRMSG(0)
 806          "Can't file source or object+interface for module \"%s\"",
 807          iname
 808       EEND;
 809    }
 810    /* findFilesForModule should enforce this */
 811    if (!(sAvail || (oAvail && iAvail)))
 812       internal("chase");
 813    /* Load objects in preference to sources if both are available */
 814    fromObj = sAvail
 815                 ? (oAvail && iAvail && timeEarlier(sTime,oTime))
 816                 : TRUE;
 817    /* ToDo: namesUpto overflow */
 818    ent->modName     = strCopy(iname);
 819    ent->details     = TRUE;
 820    ent->path        = path;
 821    ent->fromSource  = !fromObj;
 822    ent->srcExt      = sExt;
 823    ent->postponed   = FALSE;
 824    ent->lastChange  = sTime; /* ToDo: is this right? */
 825    ent->size        = fromObj ? iSize : sSize;
 826    ent->oSize       = fromObj ? oSize : 0;
 827    ent->objLoaded   = FALSE;
 828 }
 829
 830
 831
 832 static Void nukeEnding( String s )
 833 {
 834     Int l = strlen(s);
 835     if (l > 2 && strncmp(s+l-2,".o"  ,3)==0) s[l-2] = 0; else
 836     if (l > 3 && strncmp(s+l-3,".hi" ,3)==0) s[l-3] = 0; else
 837     if (l > 3 && strncmp(s+l-3,".hs" ,3)==0) s[l-3] = 0; else
 838     if (l > 4 && strncmp(s+l-4,".lhs",4)==0) s[l-4] = 0; else
 839     if (l > 4 && strncmp(s+l-4,".dll",4)==0) s[l-4] = 0; else
 840     if (l > 4 && strncmp(s+l-4,".DLL",4)==0) s[l-4] = 0;
 841 }
 842
 843 static Void local addStackEntry(s)     /* Add script to list of scripts    */
 844 String s; {                            /* to be read in ...                */
 845     String s2;
 846     Bool   found;
 847     Int    i;
 848
 849     if (namesUpto>=NUM_SCRIPTS) {
 850         ERRMSG(0) "Too many module files (maximum of %d allowed)",
 851                   NUM_SCRIPTS
 852         EEND;
 853     }
 854
 855     s = strCopy(s);
 856     nukeEnding(s);
 857     for (s2 = s; *s2; s2++)
 858        if (*s2 == SLASH && *(s2+1)) s = s2+1;
 859
 860     found = FALSE;
 861     for (i = 0; i < namesUpto; i++)
 862        if (strcmp(scriptInfo[i].modName,s)==0)
 863           found = TRUE;
 864
 865     if (!found) {
 866        makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) );
 867        namesUpto++;
 868     }
 869     free(s);
 870 }
 871
 872 /* Return TRUE if no imports were needed; FALSE otherwise. */
 873 static Bool local addScript(stacknum)   /* read single file                */
 874 Int stacknum; {
 875    static char name[FILENAME_MAX+1];
 876    Int len = scriptInfo[stacknum].size;
 877
 878 #if HUGS_FOR_WINDOWS                    /* Set clock cursor while loading  */
 879     allowBreak();
 880     SetCursor(LoadCursor(NULL, IDC_WAIT));
 881 #endif
 882
 883     //   setLastEdit(name,0);
 884
 885    nameObj[0] = 0;
 886    strcpy(name, scriptInfo[stacknum].path);
 887    strcat(name, scriptInfo[stacknum].modName);
 888    if (scriptInfo[stacknum].fromSource)
 889       strcat(name, scriptInfo[stacknum].srcExt); else
 890       strcat(name, ".hi");
 891
 892    scriptFile = name;
 893
 894    if (scriptInfo[stacknum].fromSource) {
 895       Printf("Reading script \"%s\":\n",name);
 896       needsImports = FALSE;
 897       parseScript(name,len);
 898       if (needsImports) return FALSE;
 899       checkDefns();
 900       typeCheckDefns();
 901       compileDefns();
 902    } else {
 903       Printf("Reading  iface \"%s\":\n", name);
 904       scriptFile = name;
 905       needsImports = FALSE;
 906
 907       // set nameObj for the benefit of openGHCIface
 908       strcpy(nameObj, scriptInfo[stacknum].path);
 909       strcat(nameObj, scriptInfo[stacknum].modName);
 910       strcat(nameObj, DLL_ENDING);
 911       sizeObj = scriptInfo[stacknum].oSize;
 912
 913       loadInterface(name,len);
 914       scriptFile = 0;
 915       if (needsImports) return FALSE;
 916    }
 917
 918    scriptFile = 0;
 919    preludeLoaded = TRUE;
 920    return TRUE;
 921 }
 922
 923
 924 Bool chase(imps)                        /* Process list of import requests */
 925 List imps; {
 926     Int    dstPosn;
 927     ScriptInfo tmp;
 928     Int    origPos  = numScripts;       /* keep track of original position */
 929     String origName = scriptInfo[origPos].modName;
 930     for (; nonNull(imps); imps=tl(imps)) {
 931         String iname = textToStr(textOf(hd(imps)));
 932         Int    i     = 0;
 933         for (; i<namesUpto; i++)
 934             if (strcmp(scriptInfo[i].modName,iname)==0)
 935                 break;
 936         //fprintf(stderr, "import name = %s   num = %d\n", iname, i );
 937
 938         if (i<namesUpto) {
 939            /* We should have filled in the details of each module
 940               the first time we hear about it.
 941            */
 942            assert(scriptInfo[i].details);
 943         }
 944
 945         if (i>=origPos) {               /* Neither loaded or queued        */
 946             String theName;
 947             Time   theTime;
 948             Bool   thePost;
 949             Bool   theFS;
 950
 951             needsImports = TRUE;
 952             if (scriptInfo[origPos].fromSource)
 953                scriptInfo[origPos].postponed  = TRUE;
 954
 955             if (i==namesUpto) {         /* Name not found (i==namesUpto)   */
 956                  /* Find out where it lives, whether source or object, etc */
 957                makeStackEntry ( &scriptInfo[i], iname );
 958                namesUpto++;
 959             }
 960             else
 961             if (scriptInfo[i].postponed && scriptInfo[i].fromSource) {
 962                                         /* Check for recursive dependency  */
 963                 ERRMSG(0)
 964                   "Recursive import dependency between \"%s\" and \"%s\"",
 965                   scriptInfo[origPos].modName, iname
 966                 EEND;
 967             }
 968             /* Move stack entry i to somewhere below origPos.  If i denotes
 969              * an object, destination is immediately below origPos.
 970              * Otherwise, it's underneath the queue of objects below origPos.
 971              */
 972             dstPosn = origPos-1;
 973             if (scriptInfo[i].fromSource)
 974                while (!scriptInfo[dstPosn].fromSource && dstPosn > 0)
 975                   dstPosn--;
 976
 977             dstPosn++;
 978             tmp = scriptInfo[i];
 979             for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1];
 980             scriptInfo[dstPosn] = tmp;
 981             if (dstPosn < nextNumScripts) nextNumScripts = dstPosn;
 982             origPos++;
 983         }
 984     }
 985     return needsImports;
 986 }
 987
 988 static Void local forgetScriptsFrom(scno)/* remove scripts from system     */
 989 Script scno; {
 990     Script i;
 991 #if 0
 992     for (i=scno; i<namesUpto; ++i)
 993         if (scriptName[i])
 994             free(scriptName[i]);
 995 #endif
 996     dropScriptsFrom(scno-1);
 997     namesUpto = scno;
 998     if (numScripts>namesUpto)
 999         numScripts = scno;
1000 }
1001
1002 /* --------------------------------------------------------------------------
1003  * Commands for loading and removing script files:
1004  * ------------------------------------------------------------------------*/
1005
1006 static Void local load() {           /* read filenames from command line   */
1007     String s;                        /* and add to list of scripts waiting */
1008                                      /* to be read                         */
1009     while ((s=readFilename())!=0)
1010         addStackEntry(s);
1011     readScripts(1);
1012 }
1013
1014 static Void local project() {          /* read list of script names from   */
1015     String s;                          /* project file                     */
1016
1017     if ((s=readFilename()) || currProject) {
1018         if (!s)
1019             s = strCopy(currProject);
1020         else if (readFilename()) {
1021             ERRMSG(0) "Too many project files"
1022             EEND;
1023         }
1024         else
1025             s = strCopy(s);
1026     }
1027     else {
1028         ERRMSG(0) "No project filename specified"
1029         EEND;
1030     }
1031     loadProject(s);
1032     readScripts(1);
1033 }
1034
1035 static Void local readScripts(n)        /* Reread current list of scripts, */
1036 Int n; {                                /* loading everything after and    */
1037     Time timeStamp;                     /* including the first script which*/
1038     Long fileSize;                      /* has been either changed or added*/
1039     static char name[FILENAME_MAX+1];
1040
1041     ppSmStack("readscripts-begin");
1042 #if HUGS_FOR_WINDOWS
1043     SetCursor(LoadCursor(NULL, IDC_WAIT));
1044 #endif
1045
1046 #if 0
1047     for (; n<numScripts; n++) {         /* Scan previously loaded scripts  */
1048         ppSmStack("readscripts-loop1");
1049         getFileInfo(scriptName[n], &timeStamp, &fileSize);
1050         if (timeChanged(timeStamp,lastChange[n])) {
1051             dropScriptsFrom(n-1);
1052             numScripts = n;
1053             break;
1054         }
1055     }
1056     for (; n<NUM_SCRIPTS; n++)          /* No scripts have been postponed  */
1057         postponed[n] = FALSE;           /* at this stage                   */
1058     numScripts = 0;
1059
1060     while (numScripts<namesUpto) {      /* Process any remaining scripts   */
1061         ppSmStack("readscripts-loop2");
1062         getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
1063         timeSet(lastChange[numScripts],timeStamp);
1064         if (numScripts>0)               /* no new script for prelude       */
1065             startNewScript(scriptName[numScripts]);
1066         if (addScript(scriptName[numScripts],fileSize))
1067             numScripts++;
1068         else
1069             dropScriptsFrom(numScripts-1);
1070     }
1071 #endif
1072
1073     interface(RESET);
1074
1075     for (; n<numScripts; n++) {
1076         ppSmStack("readscripts-loop2");
1077         strcpy(name, scriptInfo[n].path);
1078         strcat(name, scriptInfo[n].modName);
1079         if (scriptInfo[n].fromSource)
1080            strcat(name, scriptInfo[n].srcExt); else
1081            strcat(name, ".hi");  //ToDo: should be .o
1082         getFileInfo(name,&timeStamp, &fileSize);
1083         if (timeChanged(timeStamp,scriptInfo[n].lastChange)) {
1084            dropScriptsFrom(n-1);
1085            numScripts = n;
1086            break;
1087         }
1088     }
1089     for (; n<NUM_SCRIPTS; n++)
1090         scriptInfo[n].postponed = FALSE;
1091
1092     //numScripts = 0;
1093
1094     while (numScripts < namesUpto) {
1095 ppSmStack ( "readscripts-loop2" );
1096
1097        if (scriptInfo[numScripts].fromSource) {
1098
1099           if (numScripts>0)
1100               startNewScript(scriptInfo[numScripts].modName);
1101           nextNumScripts = NUM_SCRIPTS; //bogus initialisation
1102           if (addScript(numScripts)) {
1103              numScripts++;
1104 assert(nextNumScripts==NUM_SCRIPTS);
1105           }
1106           else
1107              dropScriptsFrom(numScripts-1);
1108        } else {
1109
1110           if (scriptInfo[numScripts].objLoaded) {
1111              numScripts++;
1112           } else {
1113              scriptInfo[numScripts].objLoaded = TRUE;
1114              /* new */
1115              if (numScripts>0)
1116                  startNewScript(scriptInfo[numScripts].modName);
1117              /* end */
1118              nextNumScripts = NUM_SCRIPTS;
1119              if (addScript(numScripts)) {
1120                 numScripts++;
1121 assert(nextNumScripts==NUM_SCRIPTS);
1122              } else {
1123                 //while (!scriptInfo[numScripts].fromSource && numScripts > 0)
1124                 //   numScripts--;
1125                 //if (scriptInfo[numScripts].fromSource)
1126                 //   numScripts++;
1127                 numScripts = nextNumScripts;
1128 assert(nextNumScripts<NUM_SCRIPTS);
1129              }
1130           }
1131        }
1132 if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
1133     }
1134
1135     finishInterfaces();
1136
1137     { Int  m     = namesUpto-1;
1138       Text mtext = findText(scriptInfo[m].modName);
1139       setCurrModule(mtext);
1140       evalModule = mtext;
1141     }
1142
1143
1144
1145     if (listScripts)
1146         whatScripts();
1147     if (numScripts<=1)
1148         setLastEdit((String)0, 0);
1149     ppSmStack("readscripts-end  ");
1150 }
1151
1152 static Void local whatScripts() {       /* list scripts in current session */
1153     int i;
1154     Printf("\nHugs session for:");
1155     if (projectLoaded)
1156         Printf(" (project: %s)",currProject);
1157     for (i=0; i<numScripts; ++i)
1158         Printf("\n%s",scriptInfo[i].modName);
1159     Putchar('\n');
1160 }
1161
1162 /* --------------------------------------------------------------------------
1163  * Access to external editor:
1164  * ------------------------------------------------------------------------*/
1165
1166 static Void local editor() {            /* interpreter-editor interface    */
1167     String newFile  = readFilename();
1168     if (newFile) {
1169         setLastEdit(newFile,0);
1170         if (readFilename()) {
1171             ERRMSG(0) "Multiple filenames not permitted"
1172             EEND;
1173         }
1174     }
1175     runEditor();
1176 }
1177
1178 static Void local find() {              /* edit file containing definition */
1179 #if 0
1180 This just plain wont work no more.
1181 ToDo: Fix!
1182     String nm = readFilename();         /* of specified name               */
1183     if (!nm) {
1184         ERRMSG(0) "No name specified"
1185         EEND;
1186     }
1187     else if (readFilename()) {
1188         ERRMSG(0) "Multiple names not permitted"
1189         EEND;
1190     }
1191     else {
1192         Text t;
1193         Cell c;
1194         setCurrModule(findEvalModule());
1195         startNewScript(0);
1196         if (nonNull(c=findTycon(t=findText(nm)))) {
1197             if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1198                 readScripts(1);
1199             }
1200         } else if (nonNull(c=findName(t))) {
1201             if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1202                 readScripts(1);
1203             }
1204         } else {
1205             ERRMSG(0) "No current definition for name \"%s\"", nm
1206             EEND;
1207         }
1208     }
1209 #endif
1210 }
1211
1212 static Void local runEditor() {         /* run editor on script lastEdit   */
1213     if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine              */
1214         readScripts(1);
1215 }
1216
1217 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1218 String fname;
1219 Int    line; {
1220     if (lastEdit)
1221         free(lastEdit);
1222     lastEdit = strCopy(fname);
1223     lastEdLine = line;
1224 #if HUGS_FOR_WINDOWS
1225     DrawStatusLine(hWndMain);           /* Redo status line                */
1226 #endif
1227 }
1228
1229 /* --------------------------------------------------------------------------
1230  * Read and evaluate an expression:
1231  * ------------------------------------------------------------------------*/
1232
1233 static Void local setModule(){/*set module in which to evaluate expressions*/
1234     String s = readFilename();
1235     if (!s) s = "";              /* :m clears the current module selection */
1236     evalModule = findText(s);
1237     setLastEdit(fileOfModule(findEvalModule()),0);
1238 }
1239
1240 static Module local findEvalModule() { /*Module in which to eval expressions*/
1241     Module m = findModule(evalModule);
1242     if (isNull(m))
1243         m = lastModule();
1244     return m;
1245 }
1246
1247 static Void local evaluator() {        /* evaluate expr and print value    */
1248     Type  type, bd;
1249     Kinds ks   = NIL;
1250
1251     setCurrModule(findEvalModule());
1252     scriptFile = 0;
1253     startNewScript(0);                 /* Enables recovery of storage      */
1254                                        /* allocated during evaluation      */
1255     parseExp();
1256     checkExp();
1257     defaultDefns = evalDefaults;
1258     type         = typeCheckExp(TRUE);
1259     if (isPolyType(type)) {
1260         ks = polySigOf(type);
1261         bd = monotypeOf(type);
1262     }
1263     else
1264         bd = type;
1265
1266     if (whatIs(bd)==QUAL) {
1267         ERRMSG(0) "Unresolved overloading" ETHEN
1268         ERRTEXT   "\n*** Type       : "    ETHEN ERRTYPE(type);
1269         ERRTEXT   "\n*** Expression : "    ETHEN ERREXPR(inputExpr);
1270         ERRTEXT   "\n"
1271         EEND;
1272     }
1273
1274 #ifdef WANT_TIMER
1275     updateTimers();
1276 #endif
1277
1278 #if 1
1279     if (typeMatches(type,ap(typeIO,typeUnit))) {
1280         inputExpr = ap(nameRunIO,inputExpr);
1281         evalExp();
1282         Putchar('\n');
1283     } else {
1284         Cell d = provePred(ks,NIL,ap(classShow,bd));
1285         if (isNull(d)) {
1286             ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1287             ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
1288             ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
1289             ERRTEXT   "\n"
1290             EEND;
1291         }
1292         inputExpr = ap2(findName(findText("show")),d,inputExpr);
1293         inputExpr = ap(findName(findText("putStr")), inputExpr);
1294         inputExpr = ap(nameRunIO, inputExpr);
1295
1296         evalExp(); printf("\n");
1297         if (addType) {
1298             printf(" :: ");
1299             printType(stdout,type);
1300             Putchar('\n');
1301         }
1302     }
1303 #endif
1304
1305 #if 0
1306    printf ( "result type is " );
1307    printType ( stdout, type );
1308    printf ( "\n" );
1309    evalExp();
1310    printf ( "\n" );
1311 #endif
1312
1313 }
1314
1315 static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
1316     if (printing) {                    /* after successful termination or  */
1317         printing = FALSE;              /* runtime error (e.g. interrupt)   */
1318         Putchar('\n');
1319         if (showStats) {
1320 #define plural(v)   v, (v==1?"":"s")
1321             Printf("%lu cell%s",plural(numCells));
1322             if (numGcs>0)
1323                 Printf(", %u garbage collection%s",plural(numGcs));
1324             Printf(")\n");
1325 #undef plural
1326         }
1327         FlushStdout();
1328         garbageCollect();
1329     }
1330 }
1331
1332 /* --------------------------------------------------------------------------
1333  * Print type of input expression:
1334  * ------------------------------------------------------------------------*/
1335
1336 static Void local showtype() {         /* print type of expression (if any)*/
1337     Cell type;
1338
1339     setCurrModule(findEvalModule());
1340     startNewScript(0);                 /* Enables recovery of storage      */
1341                                        /* allocated during evaluation      */
1342     parseExp();
1343     checkExp();
1344     defaultDefns = evalDefaults;
1345     type = typeCheckExp(FALSE);
1346     printExp(stdout,inputExpr);
1347     Printf(" :: ");
1348     printType(stdout,type);
1349     Putchar('\n');
1350 }
1351
1352 /* --------------------------------------------------------------------------
1353  * Enhanced help system:  print current list of scripts or give information
1354  * about an object.
1355  * ------------------------------------------------------------------------*/
1356
1357 static String local objToStr(m,c)
1358 Module m;
1359 Cell   c; {
1360 #if 1 || DISPLAY_QUANTIFIERS
1361     static char newVar[60];
1362     switch (whatIs(c)) {
1363         case NAME  : if (m == name(c).mod) {
1364                          sprintf(newVar,"%s", textToStr(name(c).text));
1365                      } else {
1366                          sprintf(newVar,"%s.%s",
1367                                         textToStr(module(name(c).mod).text),
1368                                         textToStr(name(c).text));
1369                      }
1370                      break;
1371
1372         case TYCON : if (m == tycon(c).mod) {
1373                          sprintf(newVar,"%s", textToStr(tycon(c).text));
1374                      } else {
1375                          sprintf(newVar,"%s.%s",
1376                                         textToStr(module(tycon(c).mod).text),
1377                                         textToStr(tycon(c).text));
1378                      }
1379                      break;
1380
1381         case CLASS : if (m == cclass(c).mod) {
1382                          sprintf(newVar,"%s", textToStr(cclass(c).text));
1383                      } else {
1384                          sprintf(newVar,"%s.%s",
1385                                         textToStr(module(cclass(c).mod).text),
1386                                         textToStr(cclass(c).text));
1387                      }
1388                      break;
1389
1390         default    : internal("objToStr");
1391     }
1392     return newVar;
1393 #else
1394     static char newVar[33];
1395     switch (whatIs(c)) {
1396         case NAME  : sprintf(newVar,"%s", textToStr(name(c).text));
1397                      break;
1398
1399         case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1400                      break;
1401
1402         case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1403                      break;
1404
1405         default    : internal("objToStr");
1406     }
1407     return newVar;
1408 #endif
1409 }
1410
1411 extern Name nameHw;
1412
1413 static Void local dumpStg( void ) {       /* print STG stuff                 */
1414     String s;
1415     Text   t;
1416     Name   n;
1417     Int    i;
1418     Cell   v;                           /* really StgVar */
1419     setCurrModule(findEvalModule());
1420     startNewScript(0);
1421     for (; (s=readFilename())!=0;) {
1422         t = findText(s);
1423         v = n = NIL;
1424         /* find the name while ignoring module scopes */
1425         for (i=NAMEMIN; i<nameHw; i++)
1426            if (name(i).text == t) n = i;
1427
1428         /* perhaps it's an "idNNNNNN" thing? */
1429         if (isNull(n) &&
1430             strlen(s) >= 3 &&
1431             s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1432            v = 0;
1433            i = 2;
1434            while (isdigit(s[i])) {
1435               v = v * 10 + (s[i]-'0');
1436               i++;
1437            }
1438            v = -v;
1439            n = nameFromStgVar(v);
1440         }
1441
1442         if (isNull(n) && whatIs(v)==STGVAR) {
1443            Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1444            Printf ( "{- stgSize of body is %d -}\n\n", stgSize(stgVarBody(v)));
1445            printStg(stderr, v );
1446         } else
1447         if (isNull(n)) {
1448            Printf ( "Unknown reference `%s'\n", s );
1449         } else
1450         if (!isName(n)) {
1451            Printf ( "Not a Name: `%s'\n", s );
1452         } else
1453         if (isNull(name(n).stgVar)) {
1454            Printf ( "Doesn't have a STG tree: %s\n", s );
1455         } else {
1456            Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1457            Printf ( "{- stgSize of body is %d -}\n\n",
1458                     stgSize(stgVarBody(name(n).stgVar)));
1459            printStg(stderr, name(n).stgVar);
1460         }
1461     }
1462 }
1463
1464 static Void local info() {              /* describe objects                */
1465     Int    count = 0;                   /* or give menu of commands        */
1466     String s;
1467
1468     setCurrModule(findEvalModule());
1469     startNewScript(0);                  /* for recovery of storage         */
1470     for (; (s=readFilename())!=0; count++) {
1471         describe(findText(s));
1472     }
1473     if (count == 0) {
1474         whatScripts();
1475     }
1476 }
1477
1478
1479 static Void local describe(t)           /* describe an object              */
1480 Text t; {
1481     Tycon  tc  = findTycon(t);
1482     Class  cl  = findClass(t);
1483     Name   nm  = findName(t);
1484     Module mod = findModule(t);
1485
1486     if (nonNull(tc)) {                  /* as a type constructor           */
1487         Type t = tc;
1488         Int  i;
1489         Inst in;
1490         for (i=0; i<tycon(tc).arity; ++i) {
1491             t = ap(t,mkOffset(i));
1492         }
1493         Printf("-- type constructor");
1494         if (kindExpert) {
1495             Printf(" with kind ");
1496             printKind(stdout,tycon(tc).kind);
1497         }
1498         Putchar('\n');
1499         switch (tycon(tc).what) {
1500             case SYNONYM      : Printf("type ");
1501                                 printType(stdout,t);
1502                                 Printf(" = ");
1503                                 printType(stdout,tycon(tc).defn);
1504                                 break;
1505
1506             case NEWTYPE      :
1507             case DATATYPE     : {   List cs = tycon(tc).defn;
1508                                     if (tycon(tc).what==DATATYPE) {
1509                                         Printf("data ");
1510                                     } else {
1511                                         Printf("newtype ");
1512                                     }
1513                                     printType(stdout,t);
1514                                     Putchar('\n');
1515                                     mapProc(printSyntax,cs);
1516                                     if (hasCfun(cs)) {
1517                                         Printf("\n-- constructors:");
1518                                     }
1519                                     for (; hasCfun(cs); cs=tl(cs)) {
1520                                         Putchar('\n');
1521                                         printExp(stdout,hd(cs));
1522                                         Printf(" :: ");
1523                                         printType(stdout,name(hd(cs)).type);
1524                                     }
1525                                     if (nonNull(cs)) {
1526                                         Printf("\n-- selectors:");
1527                                     }
1528                                     for (; nonNull(cs); cs=tl(cs)) {
1529                                         Putchar('\n');
1530                                         printExp(stdout,hd(cs));
1531                                         Printf(" :: ");
1532                                         printType(stdout,name(hd(cs)).type);
1533                                     }
1534                                 }
1535                                 break;
1536
1537             case RESTRICTSYN  : Printf("type ");
1538                                 printType(stdout,t);
1539                                 Printf(" = <restricted>");
1540                                 break;
1541         }
1542         Putchar('\n');
1543         if (nonNull(in=findFirstInst(tc))) {
1544             Printf("\n-- instances:\n");
1545             do {
1546                 showInst(in);
1547                 in = findNextInst(tc,in);
1548             } while (nonNull(in));
1549         }
1550         Putchar('\n');
1551     }
1552
1553     if (nonNull(cl)) {                  /* as a class                      */
1554         List  ins = cclass(cl).instances;
1555         Kinds ks  = cclass(cl).kinds;
1556         if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1557             Printf("-- type class");
1558         } else {
1559             Printf("-- constructor class");
1560             if (kindExpert) {
1561                 Printf(" with arity ");
1562                 printKinds(stdout,ks);
1563             }
1564         }
1565         Putchar('\n');
1566         mapProc(printSyntax,cclass(cl).members);
1567         Printf("class ");
1568         if (nonNull(cclass(cl).supers)) {
1569             printContext(stdout,cclass(cl).supers);
1570             Printf(" => ");
1571         }
1572         printPred(stdout,cclass(cl).head);
1573         if (nonNull(cclass(cl).members)) {
1574             List ms = cclass(cl).members;
1575             Printf(" where");
1576             do {
1577                 Type t = monotypeOf(name(hd(ms)).type);
1578                 Printf("\n  ");
1579                 printExp(stdout,hd(ms));
1580                 Printf(" :: ");
1581                 if (isNull(tl(fst(snd(t))))) {
1582                     t = snd(snd(t));
1583                 } else {
1584                     t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1585                 }
1586                 printType(stdout,t);
1587                 ms = tl(ms);
1588             } while (nonNull(ms));
1589         }
1590         Putchar('\n');
1591         if (nonNull(ins)) {
1592             Printf("\n-- instances:\n");
1593             do {
1594                 showInst(hd(ins));
1595                 ins = tl(ins);
1596             } while (nonNull(ins));
1597         }
1598         Putchar('\n');
1599     }
1600
1601     if (nonNull(nm)) {                  /* as a function/name              */
1602         printSyntax(nm);
1603         printExp(stdout,nm);
1604         Printf(" :: ");
1605         if (nonNull(name(nm).type)) {
1606             printType(stdout,name(nm).type);
1607         } else {
1608             Printf("<unknown type>");
1609         }
1610
1611         if (isCfun(nm)) {
1612             Printf("  -- data constructor");
1613         } else if (isMfun(nm)) {
1614             Printf("  -- class member");
1615         } else if (isSfun(nm)) {
1616             Printf("  -- selector function");
1617         }
1618         Printf("\n\n");
1619     }
1620
1621     if (nonNull(mod)) {                 /* as a module                     */
1622         List t;
1623         Printf("-- module\n");
1624
1625         Printf("\n-- values\n");
1626         for (t=module(mod).names; nonNull(t); t=tl(t)) {
1627            Name nm = hd(t);
1628            Printf ( "%s ", textToStr(name(nm).text));
1629         }
1630
1631         Printf("\n\n-- type constructors\n");
1632         for (t=module(mod).tycons; nonNull(t); t=tl(t)) {
1633            Tycon tc = hd(t);
1634            Printf ( "%s ", textToStr(tycon(tc).text));
1635         }
1636
1637         Printf("\n\n-- classes\n");
1638         for (t=module(mod).classes; nonNull(t); t=tl(t)) {
1639            Class cl = hd(t);
1640            Printf ( "%s ", textToStr(cclass(cl).text));
1641         }
1642
1643         Printf("\n\n");
1644     }
1645
1646     if (isNull(tc) && isNull(cl) && isNull(nm) && isNull(mod)) {
1647         Printf("Unknown reference `%s'\n",textToStr(t));
1648     }
1649 }
1650
1651 static Void local printSyntax(nm)
1652 Name nm; {
1653     Syntax sy = syntaxOf(nm);
1654     Text   t  = name(nm).text;
1655     String s  = textToStr(t);
1656     if (sy != defaultSyntax(t)) {
1657         Printf("infix");
1658         switch (assocOf(sy)) {
1659             case LEFT_ASS  : Putchar('l'); break;
1660             case RIGHT_ASS : Putchar('r'); break;
1661             case NON_ASS   : break;
1662         }
1663         Printf(" %i ",precOf(sy));
1664         if (isascii((int)(*s)) && isalpha((int)(*s))) {
1665             Printf("`%s`",s);
1666         } else {
1667             Printf("%s",s);
1668         }
1669         Putchar('\n');
1670     }
1671 }
1672
1673 static Void local showInst(in)          /* Display instance decl header    */
1674 Inst in; {
1675     Printf("instance ");
1676     if (nonNull(inst(in).specifics)) {
1677         printContext(stdout,inst(in).specifics);
1678         Printf(" => ");
1679     }
1680     printPred(stdout,inst(in).head);
1681     Putchar('\n');
1682 }
1683
1684 /* --------------------------------------------------------------------------
1685  * List all names currently in scope:
1686  * ------------------------------------------------------------------------*/
1687
1688 static Void local listNames() {         /* list names matching optional pat*/
1689     String pat   = readFilename();
1690     List   names = NIL;
1691     Int    width = getTerminalWidth() - 1;
1692     Int    count = 0;
1693     Int    termPos;
1694     Module mod   = findEvalModule();
1695
1696     if (pat) {                          /* First gather names to list      */
1697         do {
1698             names = addNamesMatching(pat,names);
1699         } while ((pat=readFilename())!=0);
1700     } else {
1701         names = addNamesMatching((String)0,names);
1702     }
1703     if (isNull(names)) {                /* Then print them out             */
1704         ERRMSG(0) "No names selected"
1705         EEND;
1706     }
1707     for (termPos=0; nonNull(names); names=tl(names)) {
1708         String s = objToStr(mod,hd(names));
1709         Int    l = strlen(s);
1710         if (termPos+1+l>width) {
1711             Putchar('\n');
1712             termPos = 0;
1713         } else if (termPos>0) {
1714             Putchar(' ');
1715             termPos++;
1716         }
1717         Printf("%s",s);
1718         termPos += l;
1719         count++;
1720     }
1721     Printf("\n(%d names listed)\n", count);
1722 }
1723
1724 /* --------------------------------------------------------------------------
1725  * print a prompt and read a line of input:
1726  * ------------------------------------------------------------------------*/
1727
1728 static Void local promptForInput(moduleName)
1729 String moduleName; {
1730     char promptBuffer[1000];
1731 #if 1
1732     /* This is portable but could overflow buffer */
1733     sprintf(promptBuffer,prompt,moduleName);
1734 #else
1735     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1736      * promptBuffer instead.
1737      */
1738     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1739         /* Reset prompt to a safe default to avoid an infinite loop */
1740         free(prompt);
1741         prompt = strCopy("? ");
1742         internal("Combined prompt and evaluation module name too long");
1743     }
1744 #endif
1745     if (autoMain)
1746        stringInput("main\0"); else
1747        consoleInput(promptBuffer);
1748 }
1749
1750 /* --------------------------------------------------------------------------
1751  * main read-eval-print loop, with error trapping:
1752  * ------------------------------------------------------------------------*/
1753
1754 static jmp_buf catch_error;             /* jump buffer for error trapping  */
1755
1756 static Void local interpreter(argc,argv)/* main interpreter loop           */
1757 Int    argc;
1758 String argv[]; {
1759     Int errorNumber = setjmp(catch_error);
1760
1761     if (errorNumber && autoMain) {
1762        fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
1763        exit(1);
1764     }
1765
1766     breakOn(TRUE);                      /* enable break trapping           */
1767     if (numScripts==0) {                /* only succeeds on first time,    */
1768         if (errorNumber)                /* before prelude has been loaded  */
1769             fatal("Unable to load prelude");
1770         initialize(argc,argv);
1771         forHelp();
1772     }
1773
1774     for (;;) {
1775         Command cmd;
1776         everybody(RESET);               /* reset to sensible initial state */
1777         dropScriptsFrom(numScripts-1);  /* remove partially loaded scripts */
1778                                         /* not counting prelude as a script*/
1779
1780         promptForInput(textToStr(module(findEvalModule()).text));
1781
1782         cmd = readCommand(cmds, (Char)':', (Char)'!');
1783 #ifdef WANT_TIMER
1784         updateTimers();
1785 #endif
1786         switch (cmd) {
1787             case EDIT   : editor();
1788                           break;
1789             case FIND   : find();
1790                           break;
1791             case LOAD   : clearProject();
1792                           forgetScriptsFrom(1);
1793                           load();
1794                           break;
1795             case ALSO   : clearProject();
1796                           forgetScriptsFrom(numScripts);
1797                           load();
1798                           break;
1799             case RELOAD : readScripts(1);
1800                           break;
1801             case PROJECT: project();
1802                           break;
1803             case SETMODULE :
1804                           setModule();
1805                           break;
1806             case EVAL   : evaluator();
1807                           break;
1808             case TYPEOF : showtype();
1809                           break;
1810             case NAMES  : listNames();
1811                           break;
1812             case HELP   : menu();
1813                           break;
1814             case BADCMD : guidance();
1815                           break;
1816             case SET    : set();
1817                           break;
1818             case STATS:
1819 #ifdef CRUDE_PROFILING
1820                           cp_show();
1821 #endif
1822                           break;
1823             case SYSTEM : if (shellEsc(readLine()))
1824                               Printf("Warning: Shell escape terminated abnormally\n");
1825                           break;
1826             case CHGDIR : changeDir();
1827                           break;
1828             case INFO   : info();
1829                           break;
1830             case DUMP   : dumpStg();
1831                           break;
1832             case QUIT   : return;
1833             case COLLECT: consGC = FALSE;
1834                           garbageCollect();
1835                           consGC = TRUE;
1836                           Printf("Garbage collection recovered %d cells\n",
1837                                  cellsRecovered);
1838                           break;
1839             case NOCMD  : break;
1840         }
1841 #ifdef WANT_TIMER
1842         updateTimers();
1843         Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
1844                millisecs(userElapsed), millisecs(systElapsed));
1845 #endif
1846         if (autoMain) break;
1847     }
1848     breakOn(FALSE);
1849 }
1850
1851 /* --------------------------------------------------------------------------
1852  * Display progress towards goal:
1853  * ------------------------------------------------------------------------*/
1854
1855 static Target currTarget;
1856 static Bool   aiming = FALSE;
1857 static Int    currPos;
1858 static Int    maxPos;
1859 static Int    charCount;
1860
1861 Void setGoal(what, t)                  /* Set goal for what to be t        */
1862 String what;
1863 Target t; {
1864     if (quiet) return;
1865     currTarget = (t?t:1);
1866     aiming     = TRUE;
1867     if (useDots) {
1868         currPos = strlen(what);
1869         maxPos  = getTerminalWidth() - 1;
1870         Printf("%s",what);
1871     }
1872     else
1873         for (charCount=0; *what; charCount++)
1874             Putchar(*what++);
1875     FlushStdout();
1876 }
1877
1878 Void soFar(t)                          /* Indicate progress towards goal   */
1879 Target t; {                            /* has now reached t                */
1880     if (quiet) return;
1881     if (useDots) {
1882         Int newPos = (Int)((maxPos * ((long)t))/currTarget);
1883
1884         if (newPos>maxPos)
1885             newPos = maxPos;
1886
1887         if (newPos>currPos) {
1888             do
1889                 Putchar('.');
1890             while (newPos>++currPos);
1891             FlushStdout();
1892         }
1893         FlushStdout();
1894     }
1895 }
1896
1897 Void done() {                          /* Goal has now been achieved       */
1898     if (quiet) return;
1899     if (useDots) {
1900         while (maxPos>currPos++)
1901             Putchar('.');
1902         Putchar('\n');
1903     }
1904     else
1905         for (; charCount>0; charCount--) {
1906             Putchar('\b');
1907             Putchar(' ');
1908             Putchar('\b');
1909         }
1910     aiming = FALSE;
1911     FlushStdout();
1912 }
1913
1914 static Void local failed() {           /* Goal cannot be reached due to    */
1915     if (aiming) {                      /* errors                           */
1916         aiming = FALSE;
1917         Putchar('\n');
1918         FlushStdout();
1919     }
1920 }
1921
1922 /* --------------------------------------------------------------------------
1923  * Error handling:
1924  * ------------------------------------------------------------------------*/
1925
1926 Void errHead(l)                        /* print start of error message     */
1927 Int l; {
1928     failed();                          /* failed to reach target ...       */
1929     stopAnyPrinting();
1930     FPrintf(errorStream,"ERROR");
1931
1932     if (scriptFile) {
1933         FPrintf(errorStream," \"%s\"", scriptFile);
1934         setLastEdit(scriptFile,l);
1935         if (l) FPrintf(errorStream," (line %d)",l);
1936         scriptFile = 0;
1937     }
1938     FPrintf(errorStream,": ");
1939     FFlush(errorStream);
1940 }
1941
1942 Void errFail() {                        /* terminate error message and     */
1943     Putc('\n',errorStream);             /* produce exception to return to  */
1944     FFlush(errorStream);                /* main command loop               */
1945     longjmp(catch_error,1);
1946 }
1947
1948 Void errAbort() {                       /* altern. form of error handling  */
1949     failed();                           /* used when suitable error message*/
1950     stopAnyPrinting();                  /* has already been printed        */
1951     errFail();
1952 }
1953
1954 Void internal(msg)                      /* handle internal error           */
1955 String msg; {
1956 #if HUGS_FOR_WINDOWS
1957     char buf[300];
1958     wsprintf(buf,"INTERNAL ERROR: %s",msg);
1959     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
1960 #endif
1961     failed();
1962     stopAnyPrinting();
1963     Printf("INTERNAL ERROR: %s\n",msg);
1964     FlushStdout();
1965     longjmp(catch_error,1);
1966 }
1967
1968 Void fatal(msg)                         /* handle fatal error              */
1969 String msg; {
1970 #if HUGS_FOR_WINDOWS
1971     char buf[300];
1972     wsprintf(buf,"FATAL ERROR: %s",msg);
1973     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
1974 #endif
1975     FlushStdout();
1976     Printf("\nFATAL ERROR: %s\n",msg);
1977     everybody(EXIT);
1978     exit(1);
1979 }
1980
1981 sigHandler(breakHandler) {              /* respond to break interrupt      */
1982 #if HUGS_FOR_WINDOWS
1983     MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
1984 #endif
1985     Hilite();
1986     Printf("{Interrupted!}\n");
1987     Lolite();
1988     breakOn(TRUE);  /* reinstall signal handler - redundant on BSD systems */
1989                     /* but essential on POSIX (and other?) systems         */
1990     everybody(BREAK);
1991     failed();
1992     stopAnyPrinting();
1993     FlushStdout();
1994     clearerr(stdin);
1995     longjmp(catch_error,1);
1996     sigResume;/*NOTREACHED*/
1997 }
1998
1999 /* --------------------------------------------------------------------------
2000  * Read value from environment variable or registry:
2001  * ------------------------------------------------------------------------*/
2002
2003 String fromEnv(var,def)         /* return value of:                        */
2004 String var;                     /*     environment variable named by var   */
2005 String def; {                   /* or: default value given by def          */
2006     String s = getenv(var);
2007     return (s ? s : def);
2008 }
2009
2010 /* --------------------------------------------------------------------------
2011  * String manipulation routines:
2012  * ------------------------------------------------------------------------*/
2013
2014 static String local strCopy(s)         /* make malloced copy of a string   */
2015 String s; {
2016     if (s && *s) {
2017         char *t, *r;
2018         if ((t=(char *)malloc(strlen(s)+1))==0) {
2019             ERRMSG(0) "String storage space exhausted"
2020             EEND;
2021         }
2022         for (r=t; (*r++ = *s++)!=0; ) {
2023         }
2024         return t;
2025     }
2026     return NULL;
2027 }
2028
2029 /* --------------------------------------------------------------------------
2030  * Compiler output
2031  * We can redirect compiler output (prompts, error messages, etc) by
2032  * tweaking these functions.
2033  * ------------------------------------------------------------------------*/
2034
2035 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2036
2037 #ifdef HAVE_STDARG_H
2038 #include <stdarg.h>
2039 #else
2040 #include <varargs.h>
2041 #endif
2042
2043 /* ----------------------------------------------------------------------- */
2044
2045 #define BufferSize 5000               /* size of redirected output buffer  */
2046
2047 typedef struct _HugsStream {
2048     char buffer[BufferSize];          /* buffer for redirected output      */
2049     Int  next;                        /* next space in buffer              */
2050 } HugsStream;
2051
2052 static Void   local vBufferedPrintf  Args((HugsStream*, const char*, va_list));
2053 static Void   local bufferedPutchar  Args((HugsStream*, Char));
2054 static String local bufferClear      Args((HugsStream *stream));
2055
2056 static Void local vBufferedPrintf(stream, fmt, ap)
2057 HugsStream* stream;
2058 const char* fmt;
2059 va_list     ap; {
2060     Int spaceLeft = BufferSize - stream->next;
2061     char* p = &stream->buffer[stream->next];
2062     Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2063     if (0 <= charsAdded && charsAdded < spaceLeft)
2064         stream->next += charsAdded;
2065 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2066     else
2067         stream->next = 0;
2068 #endif
2069 }
2070
2071 static Void local bufferedPutchar(stream, c)
2072 HugsStream *stream;
2073 Char        c; {
2074     if (BufferSize - stream->next >= 2) {
2075         stream->buffer[stream->next++] = c;
2076         stream->buffer[stream->next] = '\0';
2077     }
2078 }
2079
2080 static String local bufferClear(stream)
2081 HugsStream *stream; {
2082     if (stream->next == 0) {
2083         return "";
2084     } else {
2085         stream->next = 0;
2086         return stream->buffer;
2087     }
2088 }
2089
2090 /* ----------------------------------------------------------------------- */
2091
2092 static HugsStream outputStreamH;
2093 /* ADR note:
2094  * We rely on standard C semantics to initialise outputStreamH.next to 0.
2095  */
2096
2097 Void hugsEnableOutput(f)
2098 Bool f; {
2099     disableOutput = !f;
2100 }
2101
2102 String hugsClearOutputBuffer() {
2103     return bufferClear(&outputStreamH);
2104 }
2105
2106 #ifdef HAVE_STDARG_H
2107 Void hugsPrintf(const char *fmt, ...) {
2108     va_list ap;                    /* pointer into argument list           */
2109     va_start(ap, fmt);             /* make ap point to first arg after fmt */
2110     if (!disableOutput) {
2111         vprintf(fmt, ap);
2112     } else {
2113         vBufferedPrintf(&outputStreamH, fmt, ap);
2114     }
2115     va_end(ap);                    /* clean up                             */
2116 }
2117 #else
2118 Void hugsPrintf(fmt, va_alist)
2119 const char *fmt;
2120 va_dcl {
2121     va_list ap;                    /* pointer into argument list           */
2122     va_start(ap);                  /* make ap point to first arg after fmt */
2123     if (!disableOutput) {
2124         vprintf(fmt, ap);
2125     } else {
2126         vBufferedPrintf(&outputStreamH, fmt, ap);
2127     }
2128     va_end(ap);                    /* clean up                             */
2129 }
2130 #endif
2131
2132 Void hugsPutchar(c)
2133 int c; {
2134     if (!disableOutput) {
2135         putchar(c);
2136     } else {
2137         bufferedPutchar(&outputStreamH, c);
2138     }
2139 }
2140
2141 Void hugsFlushStdout() {
2142     if (!disableOutput) {
2143         fflush(stdout);
2144     }
2145 }
2146
2147 Void hugsFFlush(fp)
2148 FILE* fp; {
2149     if (!disableOutput) {
2150         fflush(fp);
2151     }
2152 }
2153
2154 #ifdef HAVE_STDARG_H
2155 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2156     va_list ap;
2157     va_start(ap, fmt);
2158     if (!disableOutput) {
2159         vfprintf(fp, fmt, ap);
2160     } else {
2161         vBufferedPrintf(&outputStreamH, fmt, ap);
2162     }
2163     va_end(ap);
2164 }
2165 #else
2166 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2167 FILE* fp;
2168 const char* fmt;
2169 va_dcl {
2170     va_list ap;
2171     va_start(ap);
2172     if (!disableOutput) {
2173         vfprintf(fp, fmt, ap);
2174     } else {
2175         vBufferedPrintf(&outputStreamH, fmt, ap);
2176     }
2177     va_end(ap);
2178 }
2179 #endif
2180
2181 Void hugsPutc(c, fp)
2182 int   c;
2183 FILE* fp; {
2184     if (!disableOutput) {
2185         putc(c,fp);
2186     } else {
2187         bufferedPutchar(&outputStreamH, c);
2188     }
2189 }
2190
2191 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2192 /* --------------------------------------------------------------------------
2193  * Send message to each component of system:
2194  * ------------------------------------------------------------------------*/
2195
2196 Void everybody(what)            /* send command `what' to each component of*/
2197 Int what; {                     /* system to respond as appropriate ...    */
2198     machdep(what);              /* The order of calling each component is  */
2199     storage(what);              /* important for the INSTALL command       */
2200     substitution(what);
2201     input(what);
2202     translateControl(what);
2203     linkControl(what);
2204     staticAnalysis(what);
2205     deriveControl(what);
2206     typeChecker(what);
2207     compiler(what);
2208     codegen(what);
2209     optimiser(what);
2210 }
2211
2212 /* --------------------------------------------------------------------------
2213  * Hugs for Windows code (WinMain and related functions)
2214  * ------------------------------------------------------------------------*/
2215
2216 #if HUGS_FOR_WINDOWS
2217 #include "winhugs.c"
2218 #endif