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