ghc/interpreter/hugs.c

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