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