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