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