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