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.39 $
  13  * $Date: 2000/02/15 13:16:19 $
  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 printf("\n");print(name(nm).type,10);printf("\n");
1878         if (isCfun(nm)) {
1879             Printf("  -- data constructor");
1880         } else if (isMfun(nm)) {
1881             Printf("  -- class member");
1882         } else if (isSfun(nm)) {
1883             Printf("  -- selector function");
1884         }
1885         Printf("\n\n");
1886     }
1887
1888
1889     if (isNull(tc) && isNull(cl) && isNull(nm)) {
1890         Printf("Unknown reference `%s'\n",textToStr(t));
1891     }
1892 }
1893
1894 static Void local printSyntax(nm)
1895 Name nm; {
1896     Syntax sy = syntaxOf(nm);
1897     Text   t  = name(nm).text;
1898     String s  = textToStr(t);
1899     if (sy != defaultSyntax(t)) {
1900         Printf("infix");
1901         switch (assocOf(sy)) {
1902             case LEFT_ASS  : Putchar('l'); break;
1903             case RIGHT_ASS : Putchar('r'); break;
1904             case NON_ASS   : break;
1905         }
1906         Printf(" %i ",precOf(sy));
1907         if (isascii((int)(*s)) && isalpha((int)(*s))) {
1908             Printf("`%s`",s);
1909         } else {
1910             Printf("%s",s);
1911         }
1912         Putchar('\n');
1913     }
1914 }
1915
1916 static Void local showInst(in)          /* Display instance decl header    */
1917 Inst in; {
1918     Printf("instance ");
1919     if (nonNull(inst(in).specifics)) {
1920         printContext(stdout,inst(in).specifics);
1921         Printf(" => ");
1922     }
1923     printPred(stdout,inst(in).head);
1924     Putchar('\n');
1925 }
1926
1927 /* --------------------------------------------------------------------------
1928  * List all names currently in scope:
1929  * ------------------------------------------------------------------------*/
1930
1931 static Void local listNames() {         /* list names matching optional pat*/
1932     String pat   = readFilename();
1933     List   names = NIL;
1934     Int    width = getTerminalWidth() - 1;
1935     Int    count = 0;
1936     Int    termPos;
1937     Module mod   = findEvalModule();
1938
1939     if (pat) {                          /* First gather names to list      */
1940         do {
1941             names = addNamesMatching(pat,names);
1942         } while ((pat=readFilename())!=0);
1943     } else {
1944         names = addNamesMatching((String)0,names);
1945     }
1946     if (isNull(names)) {                /* Then print them out             */
1947         ERRMSG(0) "No names selected"
1948         EEND;
1949     }
1950     for (termPos=0; nonNull(names); names=tl(names)) {
1951         String s = objToStr(mod,hd(names));
1952         Int    l = strlen(s);
1953         if (termPos+1+l>width) {
1954             Putchar('\n');
1955             termPos = 0;
1956         } else if (termPos>0) {
1957             Putchar(' ');
1958             termPos++;
1959         }
1960         Printf("%s",s);
1961         termPos += l;
1962         count++;
1963     }
1964     Printf("\n(%d names listed)\n", count);
1965 }
1966
1967 /* --------------------------------------------------------------------------
1968  * print a prompt and read a line of input:
1969  * ------------------------------------------------------------------------*/
1970
1971 static Void local promptForInput(moduleName)
1972 String moduleName; {
1973     char promptBuffer[1000];
1974 #if 1
1975     /* This is portable but could overflow buffer */
1976     sprintf(promptBuffer,prompt,moduleName);
1977 #else
1978     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1979      * promptBuffer instead.
1980      */
1981     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1982         /* Reset prompt to a safe default to avoid an infinite loop */
1983         free(prompt);
1984         prompt = strCopy("? ");
1985         internal("Combined prompt and evaluation module name too long");
1986     }
1987 #endif
1988     if (autoMain)
1989        stringInput("main\0"); else
1990        consoleInput(promptBuffer);
1991 }
1992
1993 /* --------------------------------------------------------------------------
1994  * main read-eval-print loop, with error trapping:
1995  * ------------------------------------------------------------------------*/
1996
1997 static jmp_buf catch_error;             /* jump buffer for error trapping  */
1998
1999 static Void local interpreter(argc,argv)/* main interpreter loop           */
2000 Int    argc;
2001 String argv[]; {
2002     Int errorNumber = setjmp(catch_error);
2003
2004     if (errorNumber && autoMain) {
2005        fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
2006        exit(1);
2007     }
2008
2009     breakOn(TRUE);                      /* enable break trapping           */
2010     if (numScripts==0) {                /* only succeeds on first time,    */
2011         if (errorNumber)                /* before prelude has been loaded  */
2012             fatal("Unable to load prelude");
2013         initialize(argc,argv);
2014         forHelp();
2015     }
2016
2017     /* initialize calls startupHaskell, which trashes our signal handlers */
2018     breakOn(TRUE);
2019
2020     for (;;) {
2021         Command cmd;
2022         everybody(RESET);               /* reset to sensible initial state */
2023         dropScriptsFrom(numScripts-1);  /* remove partially loaded scripts */
2024                                         /* not counting prelude as a script*/
2025
2026         promptForInput(textToStr(module(findEvalModule()).text));
2027
2028         cmd = readCommand(cmds, (Char)':', (Char)'!');
2029 #ifdef WANT_TIMER
2030         updateTimers();
2031 #endif
2032         switch (cmd) {
2033             case EDIT   : editor();
2034                           break;
2035             case FIND   : find();
2036                           break;
2037             case LOAD   : clearProject();
2038                           forgetScriptsFrom(N_PRELUDE_SCRIPTS);
2039                           load();
2040                           break;
2041             case ALSO   : clearProject();
2042                           forgetScriptsFrom(numScripts);
2043                           load();
2044                           break;
2045             case RELOAD : readScripts(N_PRELUDE_SCRIPTS);
2046                           break;
2047             case PROJECT: project();
2048                           break;
2049             case SETMODULE :
2050                           setModule();
2051                           break;
2052             case EVAL   : evaluator();
2053                           break;
2054             case TYPEOF : showtype();
2055                           break;
2056             case BROWSE : browse();
2057                           break;
2058 #if EXPLAIN_INSTANCE_RESOLUTION
2059             case XPLAIN : xplain();
2060                           break;
2061 #endif
2062             case NAMES  : listNames();
2063                           break;
2064             case HELP   : menu();
2065                           break;
2066             case BADCMD : guidance();
2067                           break;
2068             case SET    : set();
2069                           break;
2070             case STATS:
2071 #ifdef CRUDE_PROFILING
2072                           cp_show();
2073 #endif
2074                           break;
2075             case SYSTEM : if (shellEsc(readLine()))
2076                               Printf("Warning: Shell escape terminated abnormally\n");
2077                           break;
2078             case CHGDIR : changeDir();
2079                           break;
2080             case INFO   : info();
2081                           break;
2082             case PNTVER: Printf("-- Hugs Version %s\n",
2083                                  HUGS_VERSION);
2084                           break;
2085             case DUMP   : dumpStg();
2086                           break;
2087             case QUIT   : return;
2088             case COLLECT: consGC = FALSE;
2089                           garbageCollect();
2090                           consGC = TRUE;
2091                           Printf("Garbage collection recovered %d cells\n",
2092                                  cellsRecovered);
2093                           break;
2094             case NOCMD  : break;
2095         }
2096 #ifdef WANT_TIMER
2097         updateTimers();
2098         Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
2099                millisecs(userElapsed), millisecs(systElapsed));
2100 #endif
2101         if (autoMain) break;
2102     }
2103     breakOn(FALSE);
2104 }
2105
2106 /* --------------------------------------------------------------------------
2107  * Display progress towards goal:
2108  * ------------------------------------------------------------------------*/
2109
2110 static Target currTarget;
2111 static Bool   aiming = FALSE;
2112 static Int    currPos;
2113 static Int    maxPos;
2114 static Int    charCount;
2115
2116 Void setGoal(what, t)                  /* Set goal for what to be t        */
2117 String what;
2118 Target t; {
2119     if (quiet)
2120       return;
2121 #if EXPLAIN_INSTANCE_RESOLUTION
2122     if (showInstRes)
2123       return;
2124 #endif
2125     currTarget = (t?t:1);
2126     aiming     = TRUE;
2127     if (useDots) {
2128         currPos = strlen(what);
2129         maxPos  = getTerminalWidth() - 1;
2130         Printf("%s",what);
2131     }
2132     else
2133         for (charCount=0; *what; charCount++)
2134             Putchar(*what++);
2135     FlushStdout();
2136 }
2137
2138 Void soFar(t)                          /* Indicate progress towards goal   */
2139 Target t; {                            /* has now reached t                */
2140     if (quiet)
2141       return;
2142 #if EXPLAIN_INSTANCE_RESOLUTION
2143     if (showInstRes)
2144       return;
2145 #endif
2146     if (useDots) {
2147         Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2148
2149         if (newPos>maxPos)
2150             newPos = maxPos;
2151
2152         if (newPos>currPos) {
2153             do
2154                 Putchar('.');
2155             while (newPos>++currPos);
2156             FlushStdout();
2157         }
2158         FlushStdout();
2159     }
2160 }
2161
2162 Void done() {                          /* Goal has now been achieved       */
2163     if (quiet)
2164       return;
2165 #if EXPLAIN_INSTANCE_RESOLUTION
2166     if (showInstRes)
2167       return;
2168 #endif
2169     if (useDots) {
2170         while (maxPos>currPos++)
2171             Putchar('.');
2172         Putchar('\n');
2173     }
2174     else
2175         for (; charCount>0; charCount--) {
2176             Putchar('\b');
2177             Putchar(' ');
2178             Putchar('\b');
2179         }
2180     aiming = FALSE;
2181     FlushStdout();
2182 }
2183
2184 static Void local failed() {           /* Goal cannot be reached due to    */
2185     if (aiming) {                      /* errors                           */
2186         aiming = FALSE;
2187         Putchar('\n');
2188         FlushStdout();
2189     }
2190 }
2191
2192 /* --------------------------------------------------------------------------
2193  * Error handling:
2194  * ------------------------------------------------------------------------*/
2195
2196 Void errHead(l)                        /* print start of error message     */
2197 Int l; {
2198     failed();                          /* failed to reach target ...       */
2199     stopAnyPrinting();
2200     FPrintf(errorStream,"ERROR");
2201
2202     if (scriptFile) {
2203         FPrintf(errorStream," \"%s\"", scriptFile);
2204         setLastEdit(scriptFile,l);
2205         if (l) FPrintf(errorStream," (line %d)",l);
2206         scriptFile = 0;
2207     }
2208     FPrintf(errorStream,": ");
2209     FFlush(errorStream);
2210 }
2211
2212 Void errFail() {                        /* terminate error message and     */
2213     Putc('\n',errorStream);             /* produce exception to return to  */
2214     FFlush(errorStream);                /* main command loop               */
2215     longjmp(catch_error,1);
2216 }
2217
2218 Void errAbort() {                       /* altern. form of error handling  */
2219     failed();                           /* used when suitable error message*/
2220     stopAnyPrinting();                  /* has already been printed        */
2221     errFail();
2222 }
2223
2224 Void internal(msg)                      /* handle internal error           */
2225 String msg; {
2226 #if HUGS_FOR_WINDOWS
2227     char buf[300];
2228     wsprintf(buf,"INTERNAL ERROR: %s",msg);
2229     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2230 #endif
2231     failed();
2232     stopAnyPrinting();
2233     Printf("INTERNAL ERROR: %s\n",msg);
2234     FlushStdout();
2235     longjmp(catch_error,1);
2236 }
2237
2238 Void fatal(msg)                         /* handle fatal error              */
2239 String msg; {
2240 #if HUGS_FOR_WINDOWS
2241     char buf[300];
2242     wsprintf(buf,"FATAL ERROR: %s",msg);
2243     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2244 #endif
2245     FlushStdout();
2246     Printf("\nFATAL ERROR: %s\n",msg);
2247     everybody(EXIT);
2248     exit(1);
2249 }
2250
2251 sigHandler(breakHandler) {              /* respond to break interrupt      */
2252 #if HUGS_FOR_WINDOWS
2253     MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
2254 #endif
2255     Hilite();
2256     Printf("{Interrupted!}\n");
2257     Lolite();
2258     breakOn(TRUE);  /* reinstall signal handler - redundant on BSD systems */
2259                     /* but essential on POSIX (and other?) systems         */
2260     everybody(BREAK);
2261     failed();
2262     stopAnyPrinting();
2263     FlushStdout();
2264     clearerr(stdin);
2265     longjmp(catch_error,1);
2266     sigResume;/*NOTREACHED*/
2267 }
2268
2269 /* --------------------------------------------------------------------------
2270  * Read value from environment variable or registry:
2271  * ------------------------------------------------------------------------*/
2272
2273 String fromEnv(var,def)         /* return value of:                        */
2274 String var;                     /*     environment variable named by var   */
2275 String def; {                   /* or: default value given by def          */
2276     String s = getenv(var);
2277     return (s ? s : def);
2278 }
2279
2280 /* --------------------------------------------------------------------------
2281  * String manipulation routines:
2282  * ------------------------------------------------------------------------*/
2283
2284 static String local strCopy(s)         /* make malloced copy of a string   */
2285 String s; {
2286     if (s && *s) {
2287         char *t, *r;
2288         if ((t=(char *)malloc(strlen(s)+1))==0) {
2289             ERRMSG(0) "String storage space exhausted"
2290             EEND;
2291         }
2292         for (r=t; (*r++ = *s++)!=0; ) {
2293         }
2294         return t;
2295     }
2296     return NULL;
2297 }
2298
2299 /* --------------------------------------------------------------------------
2300  * Compiler output
2301  * We can redirect compiler output (prompts, error messages, etc) by
2302  * tweaking these functions.
2303  * ------------------------------------------------------------------------*/
2304
2305 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2306
2307 #ifdef HAVE_STDARG_H
2308 #include <stdarg.h>
2309 #else
2310 #include <varargs.h>
2311 #endif
2312
2313 /* ----------------------------------------------------------------------- */
2314
2315 #define BufferSize 10000              /* size of redirected output buffer  */
2316
2317 typedef struct _HugsStream {
2318     char buffer[BufferSize];          /* buffer for redirected output      */
2319     Int  next;                        /* next space in buffer              */
2320 } HugsStream;
2321
2322 static Void   local vBufferedPrintf  Args((HugsStream*, const char*, va_list));
2323 static Void   local bufferedPutchar  Args((HugsStream*, Char));
2324 static String local bufferClear      Args((HugsStream *stream));
2325
2326 static Void local vBufferedPrintf(stream, fmt, ap)
2327 HugsStream* stream;
2328 const char* fmt;
2329 va_list     ap; {
2330     Int spaceLeft = BufferSize - stream->next;
2331     char* p = &stream->buffer[stream->next];
2332     Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2333     if (0 <= charsAdded && charsAdded < spaceLeft)
2334         stream->next += charsAdded;
2335 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2336     else
2337         stream->next = 0;
2338 #endif
2339 }
2340
2341 static Void local bufferedPutchar(stream, c)
2342 HugsStream *stream;
2343 Char        c; {
2344     if (BufferSize - stream->next >= 2) {
2345         stream->buffer[stream->next++] = c;
2346         stream->buffer[stream->next] = '\0';
2347     }
2348 }
2349
2350 static String local bufferClear(stream)
2351 HugsStream *stream; {
2352     if (stream->next == 0) {
2353         return "";
2354     } else {
2355         stream->next = 0;
2356         return stream->buffer;
2357     }
2358 }
2359
2360 /* ----------------------------------------------------------------------- */
2361
2362 static HugsStream outputStreamH;
2363 /* ADR note:
2364  * We rely on standard C semantics to initialise outputStreamH.next to 0.
2365  */
2366
2367 Void hugsEnableOutput(f)
2368 Bool f; {
2369     disableOutput = !f;
2370 }
2371
2372 String hugsClearOutputBuffer() {
2373     return bufferClear(&outputStreamH);
2374 }
2375
2376 #ifdef HAVE_STDARG_H
2377 Void hugsPrintf(const char *fmt, ...) {
2378     va_list ap;                    /* pointer into argument list           */
2379     va_start(ap, fmt);             /* make ap point to first arg after fmt */
2380     if (!disableOutput) {
2381         vprintf(fmt, ap);
2382     } else {
2383         vBufferedPrintf(&outputStreamH, fmt, ap);
2384     }
2385     va_end(ap);                    /* clean up                             */
2386 }
2387 #else
2388 Void hugsPrintf(fmt, va_alist)
2389 const char *fmt;
2390 va_dcl {
2391     va_list ap;                    /* pointer into argument list           */
2392     va_start(ap);                  /* make ap point to first arg after fmt */
2393     if (!disableOutput) {
2394         vprintf(fmt, ap);
2395     } else {
2396         vBufferedPrintf(&outputStreamH, fmt, ap);
2397     }
2398     va_end(ap);                    /* clean up                             */
2399 }
2400 #endif
2401
2402 Void hugsPutchar(c)
2403 int c; {
2404     if (!disableOutput) {
2405         putchar(c);
2406     } else {
2407         bufferedPutchar(&outputStreamH, c);
2408     }
2409 }
2410
2411 Void hugsFlushStdout() {
2412     if (!disableOutput) {
2413         fflush(stdout);
2414     }
2415 }
2416
2417 Void hugsFFlush(fp)
2418 FILE* fp; {
2419     if (!disableOutput) {
2420         fflush(fp);
2421     }
2422 }
2423
2424 #ifdef HAVE_STDARG_H
2425 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2426     va_list ap;
2427     va_start(ap, fmt);
2428     if (!disableOutput) {
2429         vfprintf(fp, fmt, ap);
2430     } else {
2431         vBufferedPrintf(&outputStreamH, fmt, ap);
2432     }
2433     va_end(ap);
2434 }
2435 #else
2436 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2437 FILE* fp;
2438 const char* fmt;
2439 va_dcl {
2440     va_list ap;
2441     va_start(ap);
2442     if (!disableOutput) {
2443         vfprintf(fp, fmt, ap);
2444     } else {
2445         vBufferedPrintf(&outputStreamH, fmt, ap);
2446     }
2447     va_end(ap);
2448 }
2449 #endif
2450
2451 Void hugsPutc(c, fp)
2452 int   c;
2453 FILE* fp; {
2454     if (!disableOutput) {
2455         putc(c,fp);
2456     } else {
2457         bufferedPutchar(&outputStreamH, c);
2458     }
2459 }
2460
2461 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2462 /* --------------------------------------------------------------------------
2463  * Send message to each component of system:
2464  * ------------------------------------------------------------------------*/
2465
2466 Void everybody(what)            /* send command `what' to each component of*/
2467 Int what; {                     /* system to respond as appropriate ...    */
2468 #if 0
2469   fprintf ( stderr, "EVERYBODY %d\n", what );
2470 #endif
2471     machdep(what);              /* The order of calling each component is  */
2472     storage(what);              /* important for the PREPREL command       */
2473     substitution(what);
2474     input(what);
2475     translateControl(what);
2476     linkControl(what);
2477     staticAnalysis(what);
2478     deriveControl(what);
2479     typeChecker(what);
2480     compiler(what);
2481     codegen(what);
2482 }
2483
2484 /* --------------------------------------------------------------------------
2485  * Hugs for Windows code (WinMain and related functions)
2486  * ------------------------------------------------------------------------*/
2487
2488 #if HUGS_FOR_WINDOWS
2489 #include "winhugs.c"
2490 #endif