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