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.35 $
  13  * $Date: 2000/01/11 14:21:43 $
  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(1);
 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(1);
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(1);
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       /* Commented out till we understand what
1264        * this is trying to do.
1265        * Problem, you cant find a module till later.
1266        */
1267 #if 0
1268        setCurrModule(findModule(mtext));
1269 #endif
1270       evalModule = mtext;
1271     }
1272
1273
1274
1275     if (listScripts)
1276         whatScripts();
1277     if (numScripts<=1)
1278         setLastEdit((String)0, 0);
1279     ppSmStack("readscripts-end  ");
1280 }
1281
1282 static Void local whatScripts() {       /* list scripts in current session */
1283     int i;
1284     Printf("\nHugs session for:");
1285     if (projectLoaded)
1286         Printf(" (project: %s)",currProject);
1287     for (i=0; i<numScripts; ++i)
1288       Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
1289     Putchar('\n');
1290 }
1291
1292 /* --------------------------------------------------------------------------
1293  * Access to external editor:
1294  * ------------------------------------------------------------------------*/
1295
1296 static Void local editor() {            /* interpreter-editor interface    */
1297     String newFile  = readFilename();
1298     if (newFile) {
1299         setLastEdit(newFile,0);
1300         if (readFilename()) {
1301             ERRMSG(0) "Multiple filenames not permitted"
1302             EEND;
1303         }
1304     }
1305     runEditor();
1306 }
1307
1308 static Void local find() {              /* edit file containing definition */
1309 #if 0
1310 This just plain wont work no more.
1311 ToDo: Fix!
1312     String nm = readFilename();         /* of specified name               */
1313     if (!nm) {
1314         ERRMSG(0) "No name specified"
1315         EEND;
1316     }
1317     else if (readFilename()) {
1318         ERRMSG(0) "Multiple names not permitted"
1319         EEND;
1320     }
1321     else {
1322         Text t;
1323         Cell c;
1324         setCurrModule(findEvalModule());
1325         startNewScript(0);
1326         if (nonNull(c=findTycon(t=findText(nm)))) {
1327             if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1328                 readScripts(1);
1329             }
1330         } else if (nonNull(c=findName(t))) {
1331             if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1332                 readScripts(1);
1333             }
1334         } else {
1335             ERRMSG(0) "No current definition for name \"%s\"", nm
1336             EEND;
1337         }
1338     }
1339 #endif
1340 }
1341
1342 static Void local runEditor() {         /* run editor on script lastEdit   */
1343     if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine              */
1344         readScripts(1);
1345 }
1346
1347 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1348 String fname;
1349 Int    line; {
1350     if (lastEdit)
1351         free(lastEdit);
1352     lastEdit = strCopy(fname);
1353     lastEdLine = line;
1354 #if HUGS_FOR_WINDOWS
1355     DrawStatusLine(hWndMain);           /* Redo status line                */
1356 #endif
1357 }
1358
1359 /* --------------------------------------------------------------------------
1360  * Read and evaluate an expression:
1361  * ------------------------------------------------------------------------*/
1362
1363 static Void local setModule(){/*set module in which to evaluate expressions*/
1364     String s = readFilename();
1365     if (!s) s = "";              /* :m clears the current module selection */
1366     evalModule = findText(s);
1367     setLastEdit(fileOfModule(findEvalModule()),0);
1368 }
1369
1370 static Module local findEvalModule() { /*Module in which to eval expressions*/
1371     Module m = findModule(evalModule);
1372     if (isNull(m))
1373         m = lastModule();
1374     return m;
1375 }
1376
1377 static Void local evaluator() {        /* evaluate expr and print value    */
1378     Type  type, bd;
1379     Kinds ks   = NIL;
1380
1381     setCurrModule(findEvalModule());
1382     scriptFile = 0;
1383     startNewScript(0);                 /* Enables recovery of storage      */
1384                                        /* allocated during evaluation      */
1385     parseExp();
1386     checkExp();
1387     defaultDefns = evalDefaults;
1388     type         = typeCheckExp(TRUE);
1389
1390     if (isPolyType(type)) {
1391         ks = polySigOf(type);
1392         bd = monotypeOf(type);
1393     }
1394     else
1395         bd = type;
1396
1397     if (whatIs(bd)==QUAL) {
1398         ERRMSG(0) "Unresolved overloading" ETHEN
1399         ERRTEXT   "\n*** Type       : "    ETHEN ERRTYPE(type);
1400         ERRTEXT   "\n*** Expression : "    ETHEN ERREXPR(inputExpr);
1401         ERRTEXT   "\n"
1402         EEND;
1403     }
1404
1405 #ifdef WANT_TIMER
1406     updateTimers();
1407 #endif
1408
1409 #if 1
1410     if (isProgType(ks,bd)) {
1411         inputExpr = ap(nameRunIO_toplevel,inputExpr);
1412         evalExp();
1413         Putchar('\n');
1414     } else {
1415         Cell d = provePred(ks,NIL,ap(classShow,bd));
1416         if (isNull(d)) {
1417             ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1418             ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
1419             ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
1420             ERRTEXT   "\n"
1421             EEND;
1422         }
1423         inputExpr = ap2(nameShow,           d,inputExpr);
1424         inputExpr = ap (namePutStr,         inputExpr);
1425         inputExpr = ap (nameRunIO_toplevel, inputExpr);
1426
1427         evalExp(); printf("\n");
1428         if (addType) {
1429             printf(" :: ");
1430             printType(stdout,type);
1431             Putchar('\n');
1432         }
1433     }
1434
1435 #else
1436
1437    printf ( "result type is " );
1438    printType ( stdout, type );
1439    printf ( "\n" );
1440    evalExp();
1441    printf ( "\n" );
1442
1443 #endif
1444
1445 }
1446
1447 static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
1448     if (printing) {                    /* after successful termination or  */
1449         printing = FALSE;              /* runtime error (e.g. interrupt)   */
1450         Putchar('\n');
1451         if (showStats) {
1452 #define plural(v)   v, (v==1?"":"s")
1453             Printf("%lu cell%s",plural(numCells));
1454             if (numGcs>0)
1455                 Printf(", %u garbage collection%s",plural(numGcs));
1456             Printf(")\n");
1457 #undef plural
1458         }
1459         FlushStdout();
1460         garbageCollect();
1461     }
1462 }
1463
1464 /* --------------------------------------------------------------------------
1465  * Print type of input expression:
1466  * ------------------------------------------------------------------------*/
1467
1468 static Void local showtype() {         /* print type of expression (if any)*/
1469     Cell type;
1470
1471     setCurrModule(findEvalModule());
1472     startNewScript(0);                 /* Enables recovery of storage      */
1473                                        /* allocated during evaluation      */
1474     parseExp();
1475     checkExp();
1476     defaultDefns = evalDefaults;
1477     type = typeCheckExp(FALSE);
1478     printExp(stdout,inputExpr);
1479     Printf(" :: ");
1480     printType(stdout,type);
1481     Putchar('\n');
1482 }
1483
1484
1485 static Void local browseit(mod,t,all)
1486 Module mod;
1487 String t;
1488 Bool all; {
1489     if (nonNull(mod)) {
1490         Cell cs;
1491         if (nonNull(t))
1492             Printf("module %s where\n",textToStr(module(mod).text));
1493         for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1494             Name nm = hd(cs);
1495             /* only look at things defined in this module,
1496                unless `all' flag is set */
1497             if (all || name(nm).mod == mod) {
1498                 /* unwanted artifacts, like lambda lifted values,
1499                    are in the list of names, but have no types */
1500                 if (nonNull(name(nm).type)) {
1501                     printExp(stdout,nm);
1502                     Printf(" :: ");
1503                     printType(stdout,name(nm).type);
1504                     if (isCfun(nm)) {
1505                         Printf("  -- data constructor");
1506                     } else if (isMfun(nm)) {
1507                         Printf("  -- class member");
1508                     } else if (isSfun(nm)) {
1509                         Printf("  -- selector function");
1510                     }
1511                     Printf("\n");
1512                 }
1513             }
1514         }
1515     } else {
1516       if (isNull(mod)) {
1517         Printf("Unknown module %s\n",t);
1518       }
1519     }
1520 }
1521
1522 static Void local browse() {            /* browse modules                  */
1523     Int    count = 0;                   /* or give menu of commands        */
1524     String s;
1525     Bool all = FALSE;
1526
1527     setCurrModule(findEvalModule());
1528     startNewScript(0);                  /* for recovery of storage         */
1529     for (; (s=readFilename())!=0; count++)
1530         if (strcmp(s,"all") == 0) {
1531             all = TRUE;
1532             --count;
1533         } else
1534             browseit(findModule(findText(s)),s,all);
1535     if (count == 0) {
1536         browseit(findEvalModule(),NULL,all);
1537     }
1538 }
1539
1540 #if EXPLAIN_INSTANCE_RESOLUTION
1541 static Void local xplain() {         /* print type of expression (if any)*/
1542     Cell d;
1543     Bool sir = showInstRes;
1544
1545     setCurrModule(findEvalModule());
1546     startNewScript(0);                 /* Enables recovery of storage      */
1547                                        /* allocated during evaluation      */
1548     parseContext();
1549     checkContext();
1550     showInstRes = TRUE;
1551     d = provePred(NIL,NIL,hd(inputContext));
1552     if (isNull(d)) {
1553         fprintf(stdout, "not Sat\n");
1554     } else {
1555         fprintf(stdout, "Sat\n");
1556     }
1557     showInstRes = sir;
1558 }
1559 #endif
1560
1561 /* --------------------------------------------------------------------------
1562  * Enhanced help system:  print current list of scripts or give information
1563  * about an object.
1564  * ------------------------------------------------------------------------*/
1565
1566 static String local objToStr(m,c)
1567 Module m;
1568 Cell   c; {
1569 #if 1 || DISPLAY_QUANTIFIERS
1570     static char newVar[60];
1571     switch (whatIs(c)) {
1572         case NAME  : if (m == name(c).mod) {
1573                          sprintf(newVar,"%s", textToStr(name(c).text));
1574                      } else {
1575                          sprintf(newVar,"%s.%s",
1576                                         textToStr(module(name(c).mod).text),
1577                                         textToStr(name(c).text));
1578                      }
1579                      break;
1580
1581         case TYCON : if (m == tycon(c).mod) {
1582                          sprintf(newVar,"%s", textToStr(tycon(c).text));
1583                      } else {
1584                          sprintf(newVar,"%s.%s",
1585                                         textToStr(module(tycon(c).mod).text),
1586                                         textToStr(tycon(c).text));
1587                      }
1588                      break;
1589
1590         case CLASS : if (m == cclass(c).mod) {
1591                          sprintf(newVar,"%s", textToStr(cclass(c).text));
1592                      } else {
1593                          sprintf(newVar,"%s.%s",
1594                                         textToStr(module(cclass(c).mod).text),
1595                                         textToStr(cclass(c).text));
1596                      }
1597                      break;
1598
1599         default    : internal("objToStr");
1600     }
1601     return newVar;
1602 #else
1603     static char newVar[33];
1604     switch (whatIs(c)) {
1605         case NAME  : sprintf(newVar,"%s", textToStr(name(c).text));
1606                      break;
1607
1608         case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1609                      break;
1610
1611         case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1612                      break;
1613
1614         default    : internal("objToStr");
1615     }
1616     return newVar;
1617 #endif
1618 }
1619
1620 extern Name nameHw;
1621
1622 static Void local dumpStg( void ) {       /* print STG stuff                 */
1623     String s;
1624     Text   t;
1625     Name   n;
1626     Int    i;
1627     Cell   v;                           /* really StgVar */
1628     setCurrModule(findEvalModule());
1629     startNewScript(0);
1630     for (; (s=readFilename())!=0;) {
1631         t = findText(s);
1632         v = n = NIL;
1633         /* find the name while ignoring module scopes */
1634         for (i=NAMEMIN; i<nameHw; i++)
1635            if (name(i).text == t) n = i;
1636
1637         /* perhaps it's an "idNNNNNN" thing? */
1638         if (isNull(n) &&
1639             strlen(s) >= 3 &&
1640             s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1641            v = 0;
1642            i = 2;
1643            while (isdigit(s[i])) {
1644               v = v * 10 + (s[i]-'0');
1645               i++;
1646            }
1647            v = -v;
1648            n = nameFromStgVar(v);
1649         }
1650
1651         if (isNull(n) && whatIs(v)==STGVAR) {
1652            Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1653            printStg(stderr, v );
1654         } else
1655         if (isNull(n)) {
1656            Printf ( "Unknown reference `%s'\n", s );
1657         } else
1658         if (!isName(n)) {
1659            Printf ( "Not a Name: `%s'\n", s );
1660         } else
1661         if (isNull(name(n).stgVar)) {
1662            Printf ( "Doesn't have a STG tree: %s\n", s );
1663         } else {
1664            Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1665            printStg(stderr, name(n).stgVar);
1666         }
1667     }
1668 }
1669
1670 static Void local info() {              /* describe objects                */
1671     Int    count = 0;                   /* or give menu of commands        */
1672     String s;
1673
1674     setCurrModule(findEvalModule());
1675     startNewScript(0);                  /* for recovery of storage         */
1676     for (; (s=readFilename())!=0; count++) {
1677         describe(findText(s));
1678     }
1679     if (count == 0) {
1680         whatScripts();
1681     }
1682 }
1683
1684
1685 static Void local describe(t)           /* describe an object              */
1686 Text t; {
1687     Tycon  tc  = findTycon(t);
1688     Class  cl  = findClass(t);
1689     Name   nm  = findName(t);
1690
1691     if (nonNull(tc)) {                  /* as a type constructor           */
1692         Type t = tc;
1693         Int  i;
1694         Inst in;
1695         for (i=0; i<tycon(tc).arity; ++i) {
1696             t = ap(t,mkOffset(i));
1697         }
1698         Printf("-- type constructor");
1699         if (kindExpert) {
1700             Printf(" with kind ");
1701             printKind(stdout,tycon(tc).kind);
1702         }
1703         Putchar('\n');
1704         switch (tycon(tc).what) {
1705             case SYNONYM      : Printf("type ");
1706                                 printType(stdout,t);
1707                                 Printf(" = ");
1708                                 printType(stdout,tycon(tc).defn);
1709                                 break;
1710
1711             case NEWTYPE      :
1712             case DATATYPE     : {   List cs = tycon(tc).defn;
1713                                     if (tycon(tc).what==DATATYPE) {
1714                                         Printf("data ");
1715                                     } else {
1716                                         Printf("newtype ");
1717                                     }
1718                                     printType(stdout,t);
1719                                     Putchar('\n');
1720                                     mapProc(printSyntax,cs);
1721                                     if (hasCfun(cs)) {
1722                                         Printf("\n-- constructors:");
1723                                     }
1724                                     for (; hasCfun(cs); cs=tl(cs)) {
1725                                         Putchar('\n');
1726                                         printExp(stdout,hd(cs));
1727                                         Printf(" :: ");
1728                                         printType(stdout,name(hd(cs)).type);
1729                                     }
1730                                     if (nonNull(cs)) {
1731                                         Printf("\n-- selectors:");
1732                                     }
1733                                     for (; nonNull(cs); cs=tl(cs)) {
1734                                         Putchar('\n');
1735                                         printExp(stdout,hd(cs));
1736                                         Printf(" :: ");
1737                                         printType(stdout,name(hd(cs)).type);
1738                                     }
1739                                 }
1740                                 break;
1741
1742             case RESTRICTSYN  : Printf("type ");
1743                                 printType(stdout,t);
1744                                 Printf(" = <restricted>");
1745                                 break;
1746         }
1747         Putchar('\n');
1748         if (nonNull(in=findFirstInst(tc))) {
1749             Printf("\n-- instances:\n");
1750             do {
1751                 showInst(in);
1752                 in = findNextInst(tc,in);
1753             } while (nonNull(in));
1754         }
1755         Putchar('\n');
1756     }
1757
1758     if (nonNull(cl)) {                  /* as a class                      */
1759         List  ins = cclass(cl).instances;
1760         Kinds ks  = cclass(cl).kinds;
1761         if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1762             Printf("-- type class");
1763         } else {
1764             Printf("-- constructor class");
1765             if (kindExpert) {
1766                 Printf(" with arity ");
1767                 printKinds(stdout,ks);
1768             }
1769         }
1770         Putchar('\n');
1771         mapProc(printSyntax,cclass(cl).members);
1772         Printf("class ");
1773         if (nonNull(cclass(cl).supers)) {
1774             printContext(stdout,cclass(cl).supers);
1775             Printf(" => ");
1776         }
1777         printPred(stdout,cclass(cl).head);
1778
1779         if (nonNull(cclass(cl).fds)) {
1780             List   fds = cclass(cl).fds;
1781             String pre = " | ";
1782             for (; nonNull(fds); fds=tl(fds)) {
1783                 Printf(pre);
1784                 printFD(stdout,hd(fds));
1785                 pre = ", ";
1786             }
1787         }
1788
1789         if (nonNull(cclass(cl).members)) {
1790             List ms = cclass(cl).members;
1791             Printf(" where");
1792             do {
1793                 Type t = name(hd(ms)).type;
1794                 if (isPolyType(t)) {
1795                     t = monotypeOf(t);
1796                 }
1797                 Printf("\n  ");
1798                 printExp(stdout,hd(ms));
1799                 Printf(" :: ");
1800                 if (isNull(tl(fst(snd(t))))) {
1801                     t = snd(snd(t));
1802                 } else {
1803                     t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1804                 }
1805                 printType(stdout,t);
1806                 ms = tl(ms);
1807             } while (nonNull(ms));
1808         }
1809         Putchar('\n');
1810         if (nonNull(ins)) {
1811             Printf("\n-- instances:\n");
1812             do {
1813                 showInst(hd(ins));
1814                 ins = tl(ins);
1815             } while (nonNull(ins));
1816         }
1817         Putchar('\n');
1818     }
1819
1820     if (nonNull(nm)) {                  /* as a function/name              */
1821         printSyntax(nm);
1822         printExp(stdout,nm);
1823         Printf(" :: ");
1824         if (nonNull(name(nm).type)) {
1825             printType(stdout,name(nm).type);
1826         } else {
1827             Printf("<unknown type>");
1828         }
1829 printf("\n");print(name(nm).type,10);printf("\n");
1830         if (isCfun(nm)) {
1831             Printf("  -- data constructor");
1832         } else if (isMfun(nm)) {
1833             Printf("  -- class member");
1834         } else if (isSfun(nm)) {
1835             Printf("  -- selector function");
1836         }
1837         Printf("\n\n");
1838     }
1839
1840
1841     if (isNull(tc) && isNull(cl) && isNull(nm)) {
1842         Printf("Unknown reference `%s'\n",textToStr(t));
1843     }
1844 }
1845
1846 static Void local printSyntax(nm)
1847 Name nm; {
1848     Syntax sy = syntaxOf(nm);
1849     Text   t  = name(nm).text;
1850     String s  = textToStr(t);
1851     if (sy != defaultSyntax(t)) {
1852         Printf("infix");
1853         switch (assocOf(sy)) {
1854             case LEFT_ASS  : Putchar('l'); break;
1855             case RIGHT_ASS : Putchar('r'); break;
1856             case NON_ASS   : break;
1857         }
1858         Printf(" %i ",precOf(sy));
1859         if (isascii((int)(*s)) && isalpha((int)(*s))) {
1860             Printf("`%s`",s);
1861         } else {
1862             Printf("%s",s);
1863         }
1864         Putchar('\n');
1865     }
1866 }
1867
1868 static Void local showInst(in)          /* Display instance decl header    */
1869 Inst in; {
1870     Printf("instance ");
1871     if (nonNull(inst(in).specifics)) {
1872         printContext(stdout,inst(in).specifics);
1873         Printf(" => ");
1874     }
1875     printPred(stdout,inst(in).head);
1876     Putchar('\n');
1877 }
1878
1879 /* --------------------------------------------------------------------------
1880  * List all names currently in scope:
1881  * ------------------------------------------------------------------------*/
1882
1883 static Void local listNames() {         /* list names matching optional pat*/
1884     String pat   = readFilename();
1885     List   names = NIL;
1886     Int    width = getTerminalWidth() - 1;
1887     Int    count = 0;
1888     Int    termPos;
1889     Module mod   = findEvalModule();
1890
1891     if (pat) {                          /* First gather names to list      */
1892         do {
1893             names = addNamesMatching(pat,names);
1894         } while ((pat=readFilename())!=0);
1895     } else {
1896         names = addNamesMatching((String)0,names);
1897     }
1898     if (isNull(names)) {                /* Then print them out             */
1899         ERRMSG(0) "No names selected"
1900         EEND;
1901     }
1902     for (termPos=0; nonNull(names); names=tl(names)) {
1903         String s = objToStr(mod,hd(names));
1904         Int    l = strlen(s);
1905         if (termPos+1+l>width) {
1906             Putchar('\n');
1907             termPos = 0;
1908         } else if (termPos>0) {
1909             Putchar(' ');
1910             termPos++;
1911         }
1912         Printf("%s",s);
1913         termPos += l;
1914         count++;
1915     }
1916     Printf("\n(%d names listed)\n", count);
1917 }
1918
1919 /* --------------------------------------------------------------------------
1920  * print a prompt and read a line of input:
1921  * ------------------------------------------------------------------------*/
1922
1923 static Void local promptForInput(moduleName)
1924 String moduleName; {
1925     char promptBuffer[1000];
1926 #if 1
1927     /* This is portable but could overflow buffer */
1928     sprintf(promptBuffer,prompt,moduleName);
1929 #else
1930     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1931      * promptBuffer instead.
1932      */
1933     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1934         /* Reset prompt to a safe default to avoid an infinite loop */
1935         free(prompt);
1936         prompt = strCopy("? ");
1937         internal("Combined prompt and evaluation module name too long");
1938     }
1939 #endif
1940     if (autoMain)
1941        stringInput("main\0"); else
1942        consoleInput(promptBuffer);
1943 }
1944
1945 /* --------------------------------------------------------------------------
1946  * main read-eval-print loop, with error trapping:
1947  * ------------------------------------------------------------------------*/
1948
1949 static jmp_buf catch_error;             /* jump buffer for error trapping  */
1950
1951 static Void local interpreter(argc,argv)/* main interpreter loop           */
1952 Int    argc;
1953 String argv[]; {
1954     Int errorNumber = setjmp(catch_error);
1955
1956     if (errorNumber && autoMain) {
1957        fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
1958        exit(1);
1959     }
1960
1961     breakOn(TRUE);                      /* enable break trapping           */
1962     if (numScripts==0) {                /* only succeeds on first time,    */
1963         if (errorNumber)                /* before prelude has been loaded  */
1964             fatal("Unable to load prelude");
1965         initialize(argc,argv);
1966         forHelp();
1967     }
1968
1969     /* initialize calls startupHaskell, which trashes our signal handlers */
1970     breakOn(TRUE);
1971
1972     for (;;) {
1973         Command cmd;
1974         everybody(RESET);               /* reset to sensible initial state */
1975         dropScriptsFrom(numScripts-1);  /* remove partially loaded scripts */
1976                                         /* not counting prelude as a script*/
1977
1978         promptForInput(textToStr(module(findEvalModule()).text));
1979
1980         cmd = readCommand(cmds, (Char)':', (Char)'!');
1981 #ifdef WANT_TIMER
1982         updateTimers();
1983 #endif
1984         switch (cmd) {
1985             case EDIT   : editor();
1986                           break;
1987             case FIND   : find();
1988                           break;
1989             case LOAD   : clearProject();
1990                           forgetScriptsFrom(1);
1991                           load();
1992                           break;
1993             case ALSO   : clearProject();
1994                           forgetScriptsFrom(numScripts);
1995                           load();
1996                           break;
1997             case RELOAD : readScripts(1);
1998                           break;
1999             case PROJECT: project();
2000                           break;
2001             case SETMODULE :
2002                           setModule();
2003                           break;
2004             case EVAL   : evaluator();
2005                           break;
2006             case TYPEOF : showtype();
2007                           break;
2008             case BROWSE : browse();
2009                           break;
2010 #if EXPLAIN_INSTANCE_RESOLUTION
2011             case XPLAIN : xplain();
2012                           break;
2013 #endif
2014             case NAMES  : listNames();
2015                           break;
2016             case HELP   : menu();
2017                           break;
2018             case BADCMD : guidance();
2019                           break;
2020             case SET    : set();
2021                           break;
2022             case STATS:
2023 #ifdef CRUDE_PROFILING
2024                           cp_show();
2025 #endif
2026                           break;
2027             case SYSTEM : if (shellEsc(readLine()))
2028                               Printf("Warning: Shell escape terminated abnormally\n");
2029                           break;
2030             case CHGDIR : changeDir();
2031                           break;
2032             case INFO   : info();
2033                           break;
2034             case PNTVER: Printf("-- Hugs Version %s\n",
2035                                  HUGS_VERSION);
2036                           break;
2037             case DUMP   : dumpStg();
2038                           break;
2039             case QUIT   : return;
2040             case COLLECT: consGC = FALSE;
2041                           garbageCollect();
2042                           consGC = TRUE;
2043                           Printf("Garbage collection recovered %d cells\n",
2044                                  cellsRecovered);
2045                           break;
2046             case NOCMD  : break;
2047         }
2048 #ifdef WANT_TIMER
2049         updateTimers();
2050         Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
2051                millisecs(userElapsed), millisecs(systElapsed));
2052 #endif
2053         if (autoMain) break;
2054     }
2055     breakOn(FALSE);
2056 }
2057
2058 /* --------------------------------------------------------------------------
2059  * Display progress towards goal:
2060  * ------------------------------------------------------------------------*/
2061
2062 static Target currTarget;
2063 static Bool   aiming = FALSE;
2064 static Int    currPos;
2065 static Int    maxPos;
2066 static Int    charCount;
2067
2068 Void setGoal(what, t)                  /* Set goal for what to be t        */
2069 String what;
2070 Target t; {
2071     if (quiet)
2072       return;
2073 #if EXPLAIN_INSTANCE_RESOLUTION
2074     if (showInstRes)
2075       return;
2076 #endif
2077     currTarget = (t?t:1);
2078     aiming     = TRUE;
2079     if (useDots) {
2080         currPos = strlen(what);
2081         maxPos  = getTerminalWidth() - 1;
2082         Printf("%s",what);
2083     }
2084     else
2085         for (charCount=0; *what; charCount++)
2086             Putchar(*what++);
2087     FlushStdout();
2088 }
2089
2090 Void soFar(t)                          /* Indicate progress towards goal   */
2091 Target t; {                            /* has now reached t                */
2092     if (quiet)
2093       return;
2094 #if EXPLAIN_INSTANCE_RESOLUTION
2095     if (showInstRes)
2096       return;
2097 #endif
2098     if (useDots) {
2099         Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2100
2101         if (newPos>maxPos)
2102             newPos = maxPos;
2103
2104         if (newPos>currPos) {
2105             do
2106                 Putchar('.');
2107             while (newPos>++currPos);
2108             FlushStdout();
2109         }
2110         FlushStdout();
2111     }
2112 }
2113
2114 Void done() {                          /* Goal has now been achieved       */
2115     if (quiet)
2116       return;
2117 #if EXPLAIN_INSTANCE_RESOLUTION
2118     if (showInstRes)
2119       return;
2120 #endif
2121     if (useDots) {
2122         while (maxPos>currPos++)
2123             Putchar('.');
2124         Putchar('\n');
2125     }
2126     else
2127         for (; charCount>0; charCount--) {
2128             Putchar('\b');
2129             Putchar(' ');
2130             Putchar('\b');
2131         }
2132     aiming = FALSE;
2133     FlushStdout();
2134 }
2135
2136 static Void local failed() {           /* Goal cannot be reached due to    */
2137     if (aiming) {                      /* errors                           */
2138         aiming = FALSE;
2139         Putchar('\n');
2140         FlushStdout();
2141     }
2142 }
2143
2144 /* --------------------------------------------------------------------------
2145  * Error handling:
2146  * ------------------------------------------------------------------------*/
2147
2148 Void errHead(l)                        /* print start of error message     */
2149 Int l; {
2150     failed();                          /* failed to reach target ...       */
2151     stopAnyPrinting();
2152     FPrintf(errorStream,"ERROR");
2153
2154     if (scriptFile) {
2155         FPrintf(errorStream," \"%s\"", scriptFile);
2156         setLastEdit(scriptFile,l);
2157         if (l) FPrintf(errorStream," (line %d)",l);
2158         scriptFile = 0;
2159     }
2160     FPrintf(errorStream,": ");
2161     FFlush(errorStream);
2162 }
2163
2164 Void errFail() {                        /* terminate error message and     */
2165     Putc('\n',errorStream);             /* produce exception to return to  */
2166     FFlush(errorStream);                /* main command loop               */
2167     longjmp(catch_error,1);
2168 }
2169
2170 Void errAbort() {                       /* altern. form of error handling  */
2171     failed();                           /* used when suitable error message*/
2172     stopAnyPrinting();                  /* has already been printed        */
2173     errFail();
2174 }
2175
2176 Void internal(msg)                      /* handle internal error           */
2177 String msg; {
2178 #if HUGS_FOR_WINDOWS
2179     char buf[300];
2180     wsprintf(buf,"INTERNAL ERROR: %s",msg);
2181     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2182 #endif
2183     failed();
2184     stopAnyPrinting();
2185     Printf("INTERNAL ERROR: %s\n",msg);
2186     FlushStdout();
2187     longjmp(catch_error,1);
2188 }
2189
2190 Void fatal(msg)                         /* handle fatal error              */
2191 String msg; {
2192 #if HUGS_FOR_WINDOWS
2193     char buf[300];
2194     wsprintf(buf,"FATAL ERROR: %s",msg);
2195     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2196 #endif
2197     FlushStdout();
2198     Printf("\nFATAL ERROR: %s\n",msg);
2199     everybody(EXIT);
2200     exit(1);
2201 }
2202
2203 sigHandler(breakHandler) {              /* respond to break interrupt      */
2204 #if HUGS_FOR_WINDOWS
2205     MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
2206 #endif
2207     Hilite();
2208     Printf("{Interrupted!}\n");
2209     Lolite();
2210     breakOn(TRUE);  /* reinstall signal handler - redundant on BSD systems */
2211                     /* but essential on POSIX (and other?) systems         */
2212     everybody(BREAK);
2213     failed();
2214     stopAnyPrinting();
2215     FlushStdout();
2216     clearerr(stdin);
2217     longjmp(catch_error,1);
2218     sigResume;/*NOTREACHED*/
2219 }
2220
2221 /* --------------------------------------------------------------------------
2222  * Read value from environment variable or registry:
2223  * ------------------------------------------------------------------------*/
2224
2225 String fromEnv(var,def)         /* return value of:                        */
2226 String var;                     /*     environment variable named by var   */
2227 String def; {                   /* or: default value given by def          */
2228     String s = getenv(var);
2229     return (s ? s : def);
2230 }
2231
2232 /* --------------------------------------------------------------------------
2233  * String manipulation routines:
2234  * ------------------------------------------------------------------------*/
2235
2236 static String local strCopy(s)         /* make malloced copy of a string   */
2237 String s; {
2238     if (s && *s) {
2239         char *t, *r;
2240         if ((t=(char *)malloc(strlen(s)+1))==0) {
2241             ERRMSG(0) "String storage space exhausted"
2242             EEND;
2243         }
2244         for (r=t; (*r++ = *s++)!=0; ) {
2245         }
2246         return t;
2247     }
2248     return NULL;
2249 }
2250
2251 /* --------------------------------------------------------------------------
2252  * Compiler output
2253  * We can redirect compiler output (prompts, error messages, etc) by
2254  * tweaking these functions.
2255  * ------------------------------------------------------------------------*/
2256
2257 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2258
2259 #ifdef HAVE_STDARG_H
2260 #include <stdarg.h>
2261 #else
2262 #include <varargs.h>
2263 #endif
2264
2265 /* ----------------------------------------------------------------------- */
2266
2267 #define BufferSize 10000              /* size of redirected output buffer  */
2268
2269 typedef struct _HugsStream {
2270     char buffer[BufferSize];          /* buffer for redirected output      */
2271     Int  next;                        /* next space in buffer              */
2272 } HugsStream;
2273
2274 static Void   local vBufferedPrintf  Args((HugsStream*, const char*, va_list));
2275 static Void   local bufferedPutchar  Args((HugsStream*, Char));
2276 static String local bufferClear      Args((HugsStream *stream));
2277
2278 static Void local vBufferedPrintf(stream, fmt, ap)
2279 HugsStream* stream;
2280 const char* fmt;
2281 va_list     ap; {
2282     Int spaceLeft = BufferSize - stream->next;
2283     char* p = &stream->buffer[stream->next];
2284     Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2285     if (0 <= charsAdded && charsAdded < spaceLeft)
2286         stream->next += charsAdded;
2287 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2288     else
2289         stream->next = 0;
2290 #endif
2291 }
2292
2293 static Void local bufferedPutchar(stream, c)
2294 HugsStream *stream;
2295 Char        c; {
2296     if (BufferSize - stream->next >= 2) {
2297         stream->buffer[stream->next++] = c;
2298         stream->buffer[stream->next] = '\0';
2299     }
2300 }
2301
2302 static String local bufferClear(stream)
2303 HugsStream *stream; {
2304     if (stream->next == 0) {
2305         return "";
2306     } else {
2307         stream->next = 0;
2308         return stream->buffer;
2309     }
2310 }
2311
2312 /* ----------------------------------------------------------------------- */
2313
2314 static HugsStream outputStreamH;
2315 /* ADR note:
2316  * We rely on standard C semantics to initialise outputStreamH.next to 0.
2317  */
2318
2319 Void hugsEnableOutput(f)
2320 Bool f; {
2321     disableOutput = !f;
2322 }
2323
2324 String hugsClearOutputBuffer() {
2325     return bufferClear(&outputStreamH);
2326 }
2327
2328 #ifdef HAVE_STDARG_H
2329 Void hugsPrintf(const char *fmt, ...) {
2330     va_list ap;                    /* pointer into argument list           */
2331     va_start(ap, fmt);             /* make ap point to first arg after fmt */
2332     if (!disableOutput) {
2333         vprintf(fmt, ap);
2334     } else {
2335         vBufferedPrintf(&outputStreamH, fmt, ap);
2336     }
2337     va_end(ap);                    /* clean up                             */
2338 }
2339 #else
2340 Void hugsPrintf(fmt, va_alist)
2341 const char *fmt;
2342 va_dcl {
2343     va_list ap;                    /* pointer into argument list           */
2344     va_start(ap);                  /* make ap point to first arg after fmt */
2345     if (!disableOutput) {
2346         vprintf(fmt, ap);
2347     } else {
2348         vBufferedPrintf(&outputStreamH, fmt, ap);
2349     }
2350     va_end(ap);                    /* clean up                             */
2351 }
2352 #endif
2353
2354 Void hugsPutchar(c)
2355 int c; {
2356     if (!disableOutput) {
2357         putchar(c);
2358     } else {
2359         bufferedPutchar(&outputStreamH, c);
2360     }
2361 }
2362
2363 Void hugsFlushStdout() {
2364     if (!disableOutput) {
2365         fflush(stdout);
2366     }
2367 }
2368
2369 Void hugsFFlush(fp)
2370 FILE* fp; {
2371     if (!disableOutput) {
2372         fflush(fp);
2373     }
2374 }
2375
2376 #ifdef HAVE_STDARG_H
2377 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2378     va_list ap;
2379     va_start(ap, fmt);
2380     if (!disableOutput) {
2381         vfprintf(fp, fmt, ap);
2382     } else {
2383         vBufferedPrintf(&outputStreamH, fmt, ap);
2384     }
2385     va_end(ap);
2386 }
2387 #else
2388 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2389 FILE* fp;
2390 const char* fmt;
2391 va_dcl {
2392     va_list ap;
2393     va_start(ap);
2394     if (!disableOutput) {
2395         vfprintf(fp, fmt, ap);
2396     } else {
2397         vBufferedPrintf(&outputStreamH, fmt, ap);
2398     }
2399     va_end(ap);
2400 }
2401 #endif
2402
2403 Void hugsPutc(c, fp)
2404 int   c;
2405 FILE* fp; {
2406     if (!disableOutput) {
2407         putc(c,fp);
2408     } else {
2409         bufferedPutchar(&outputStreamH, c);
2410     }
2411 }
2412
2413 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2414 /* --------------------------------------------------------------------------
2415  * Send message to each component of system:
2416  * ------------------------------------------------------------------------*/
2417
2418 Void everybody(what)            /* send command `what' to each component of*/
2419 Int what; {                     /* system to respond as appropriate ...    */
2420 #if 0
2421   fprintf ( stderr, "EVERYBODY %d\n", what );
2422 #endif
2423     machdep(what);              /* The order of calling each component is  */
2424     storage(what);              /* important for the PREPREL command       */
2425     substitution(what);
2426     input(what);
2427     translateControl(what);
2428     linkControl(what);
2429     staticAnalysis(what);
2430     deriveControl(what);
2431     typeChecker(what);
2432     compiler(what);
2433     codegen(what);
2434 }
2435
2436 /* --------------------------------------------------------------------------
2437  * Hugs for Windows code (WinMain and related functions)
2438  * ------------------------------------------------------------------------*/
2439
2440 #if HUGS_FOR_WINDOWS
2441 #include "winhugs.c"
2442 #endif