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