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