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.34 $
  13  * $Date: 2000/01/10 16:27:03 $
  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    Bool didPrelude;
 969    static char name[FILENAME_MAX+1];
 970    Int len = scriptInfo[stacknum].size;
 971
 972 #if HUGS_FOR_WINDOWS                    /* Set clock cursor while loading  */
 973     allowBreak();
 974     SetCursor(LoadCursor(NULL, IDC_WAIT));
 975 #endif
 976
 977     //   setLastEdit(name,0);
 978
 979    strcpy(name, scriptInfo[stacknum].path);
 980    strcat(name, scriptInfo[stacknum].modName);
 981    if (scriptInfo[stacknum].fromSource)
 982       strcat(name, scriptInfo[stacknum].srcExt); else
 983       strcat(name, ".u_hi");
 984
 985    scriptFile = name;
 986
 987    if (scriptInfo[stacknum].fromSource) {
 988       if (lastWasObject) {
 989          didPrelude = processInterfaces();
 990          if (didPrelude) {
 991             preludeLoaded = TRUE;
 992             everybody(POSTPREL);
 993          }
 994       }
 995       lastWasObject = FALSE;
 996       Printf("Reading script \"%s\":\n",name);
 997       needsImports = FALSE;
 998       parseScript(name,len);
 999       if (needsImports) return FALSE;
1000       checkDefns();
1001       typeCheckDefns();
1002       compileDefns();
1003    } else {
1004       Cell    iface;
1005       List    imports;
1006       ZTriple iface_info;
1007       char    nameObj[FILENAME_MAX+1];
1008       Int     sizeObj;
1009
1010       Printf("Reading  iface \"%s\":\n", name);
1011       scriptFile = name;
1012       needsImports = FALSE;
1013
1014       // set nameObj for the benefit of openGHCIface
1015       strcpy(nameObj, scriptInfo[stacknum].path);
1016       strcat(nameObj, scriptInfo[stacknum].modName);
1017       strcat(nameObj, DLL_ENDING);
1018       sizeObj = scriptInfo[stacknum].oSize;
1019
1020       iface = readInterface(name,len);
1021       imports = zsnd(iface); iface = zfst(iface);
1022
1023       if (nonNull(imports)) chase(imports);
1024       scriptFile = 0;
1025       lastWasObject = TRUE;
1026
1027       iface_info = ztriple(iface, findText(nameObj), mkInt(sizeObj) );
1028       ifaces_outstanding = cons(iface_info,ifaces_outstanding);
1029
1030       if (needsImports) return FALSE;
1031    }
1032
1033    scriptFile = 0;
1034
1035    return TRUE;
1036 }
1037
1038
1039 Bool chase(imps)                        /* Process list of import requests */
1040 List imps; {
1041     Int    dstPosn;
1042     ScriptInfo tmp;
1043     Int    origPos  = numScripts;       /* keep track of original position */
1044     String origName = scriptInfo[origPos].modName;
1045     for (; nonNull(imps); imps=tl(imps)) {
1046         String iname = textToStr(textOf(hd(imps)));
1047         Int    i     = 0;
1048         for (; i<namesUpto; i++)
1049             if (strcmp(scriptInfo[i].modName,iname)==0)
1050                 break;
1051         //fprintf(stderr, "import name = %s   num = %d\n", iname, i );
1052
1053         if (i<namesUpto) {
1054            /* We should have filled in the details of each module
1055               the first time we hear about it.
1056            */
1057            assert(scriptInfo[i].details);
1058         }
1059
1060         if (i>=origPos) {               /* Neither loaded or queued        */
1061             String theName;
1062             Time   theTime;
1063             Bool   thePost;
1064             Bool   theFS;
1065
1066             needsImports = TRUE;
1067             if (scriptInfo[origPos].fromSource)
1068                scriptInfo[origPos].postponed  = TRUE;
1069
1070             if (i==namesUpto) {         /* Name not found (i==namesUpto)   */
1071                  /* Find out where it lives, whether source or object, etc */
1072                makeStackEntry ( &scriptInfo[i], iname );
1073                namesUpto++;
1074             }
1075             else
1076             if (scriptInfo[i].postponed && scriptInfo[i].fromSource) {
1077                                         /* Check for recursive dependency  */
1078                 ERRMSG(0)
1079                   "Recursive import dependency between \"%s\" and \"%s\"",
1080                   scriptInfo[origPos].modName, iname
1081                 EEND;
1082             }
1083             /* Move stack entry i to somewhere below origPos.  If i denotes
1084              * an object, destination is immediately below origPos.
1085              * Otherwise, it's underneath the queue of objects below origPos.
1086              */
1087             dstPosn = origPos-1;
1088             if (scriptInfo[i].fromSource)
1089                while (!scriptInfo[dstPosn].fromSource && dstPosn > 0)
1090                   dstPosn--;
1091
1092             dstPosn++;
1093             tmp = scriptInfo[i];
1094             for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1];
1095             scriptInfo[dstPosn] = tmp;
1096             if (dstPosn < nextNumScripts) nextNumScripts = dstPosn;
1097             origPos++;
1098         }
1099     }
1100     return needsImports;
1101 }
1102
1103 static Void local forgetScriptsFrom(scno)/* remove scripts from system     */
1104 Script scno; {
1105     Script i;
1106 #if 0
1107     for (i=scno; i<namesUpto; ++i)
1108         if (scriptName[i])
1109             free(scriptName[i]);
1110 #endif
1111     dropScriptsFrom(scno-1);
1112     namesUpto = scno;
1113     if (numScripts>namesUpto)
1114         numScripts = scno;
1115 }
1116
1117 /* --------------------------------------------------------------------------
1118  * Commands for loading and removing script files:
1119  * ------------------------------------------------------------------------*/
1120
1121 static Void local load() {           /* read filenames from command line   */
1122     String s;                        /* and add to list of scripts waiting */
1123                                      /* to be read                         */
1124     while ((s=readFilename())!=0)
1125         addStackEntry(s);
1126     readScripts(1);
1127 }
1128
1129 static Void local project() {          /* read list of script names from   */
1130     String s;                          /* project file                     */
1131
1132     if ((s=readFilename()) || currProject) {
1133         if (!s)
1134             s = strCopy(currProject);
1135         else if (readFilename()) {
1136             ERRMSG(0) "Too many project files"
1137             EEND;
1138         }
1139         else
1140             s = strCopy(s);
1141     }
1142     else {
1143         ERRMSG(0) "No project filename specified"
1144         EEND;
1145     }
1146     loadProject(s);
1147     readScripts(1);
1148 }
1149
1150 static Void local readScripts(n)        /* Reread current list of scripts, */
1151 Int n; {                                /* loading everything after and    */
1152     Time timeStamp;                     /* including the first script which*/
1153     Long fileSize;                      /* has been either changed or added*/
1154     static char name[FILENAME_MAX+1];
1155     Bool didPrelude;
1156
1157     lastWasObject = FALSE;
1158     ppSmStack("readscripts-begin");
1159 #if HUGS_FOR_WINDOWS
1160     SetCursor(LoadCursor(NULL, IDC_WAIT));
1161 #endif
1162
1163 #if 0
1164     for (; n<numScripts; n++) {         /* Scan previously loaded scripts  */
1165         ppSmStack("readscripts-loop1");
1166         getFileInfo(scriptName[n], &timeStamp, &fileSize);
1167         if (timeChanged(timeStamp,lastChange[n])) {
1168             dropScriptsFrom(n-1);
1169             numScripts = n;
1170             break;
1171         }
1172     }
1173     for (; n<NUM_SCRIPTS; n++)          /* No scripts have been postponed  */
1174         postponed[n] = FALSE;           /* at this stage                   */
1175     numScripts = 0;
1176
1177     while (numScripts<namesUpto) {      /* Process any remaining scripts   */
1178         ppSmStack("readscripts-loop2");
1179         getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
1180         timeSet(lastChange[numScripts],timeStamp);
1181         if (numScripts>0)               /* no new script for prelude       */
1182             startNewScript(scriptName[numScripts]);
1183         if (addScript(scriptName[numScripts],fileSize))
1184             numScripts++;
1185         else
1186             dropScriptsFrom(numScripts-1);
1187     }
1188 #endif
1189
1190     interface(RESET);
1191
1192     for (; n<numScripts; n++) {
1193         ppSmStack("readscripts-loop2");
1194         strcpy(name, scriptInfo[n].path);
1195         strcat(name, scriptInfo[n].modName);
1196         if (scriptInfo[n].fromSource)
1197            strcat(name, scriptInfo[n].srcExt); else
1198            strcat(name, ".u_hi");  //ToDo: should be .o
1199         getFileInfo(name,&timeStamp, &fileSize);
1200         if (timeChanged(timeStamp,scriptInfo[n].lastChange)) {
1201            dropScriptsFrom(n-1);
1202            numScripts = n;
1203            break;
1204         }
1205     }
1206     for (; n<NUM_SCRIPTS; n++)
1207         scriptInfo[n].postponed = FALSE;
1208
1209     //numScripts = 0;
1210
1211     while (numScripts < namesUpto) {
1212        ppSmStack ( "readscripts-loop2" );
1213
1214        if (scriptInfo[numScripts].fromSource) {
1215
1216           if (numScripts>0)
1217               startNewScript(scriptInfo[numScripts].modName);
1218           nextNumScripts = NUM_SCRIPTS; //bogus initialisation
1219           if (addScript(numScripts)) {
1220              numScripts++;
1221              assert(nextNumScripts==NUM_SCRIPTS);
1222           }
1223           else
1224              dropScriptsFrom(numScripts-1);
1225
1226        } else {
1227
1228           if (scriptInfo[numScripts].objLoaded) {
1229              numScripts++;
1230           } else {
1231              scriptInfo[numScripts].objLoaded = TRUE;
1232              /* new */
1233              if (numScripts>0)
1234                  startNewScript(scriptInfo[numScripts].modName);
1235              /* end */
1236              nextNumScripts = NUM_SCRIPTS;
1237              if (addScript(numScripts)) {
1238                 numScripts++;
1239                 assert(nextNumScripts==NUM_SCRIPTS);
1240              } else {
1241                 //while (!scriptInfo[numScripts].fromSource && numScripts > 0)
1242                 //   numScripts--;
1243                 //if (scriptInfo[numScripts].fromSource)
1244                 //   numScripts++;
1245                 numScripts = nextNumScripts;
1246                 assert(nextNumScripts<NUM_SCRIPTS);
1247              }
1248           }
1249        }
1250        if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
1251     }
1252
1253     didPrelude = processInterfaces();
1254     if (didPrelude) {
1255        preludeLoaded = TRUE;
1256        everybody(POSTPREL);
1257     }
1258
1259
1260     { Int  m     = namesUpto-1;
1261       Text mtext = findText(scriptInfo[m].modName);
1262       /* Commented out till we understand what
1263        * this is trying to do.
1264        * Problem, you cant find a module till later.
1265        */
1266 #if 0
1267        setCurrModule(findModule(mtext));
1268 #endif
1269       evalModule = mtext;
1270     }
1271
1272
1273
1274     if (listScripts)
1275         whatScripts();
1276     if (numScripts<=1)
1277         setLastEdit((String)0, 0);
1278     ppSmStack("readscripts-end  ");
1279 }
1280
1281 static Void local whatScripts() {       /* list scripts in current session */
1282     int i;
1283     Printf("\nHugs session for:");
1284     if (projectLoaded)
1285         Printf(" (project: %s)",currProject);
1286     for (i=0; i<numScripts; ++i)
1287       Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
1288     Putchar('\n');
1289 }
1290
1291 /* --------------------------------------------------------------------------
1292  * Access to external editor:
1293  * ------------------------------------------------------------------------*/
1294
1295 static Void local editor() {            /* interpreter-editor interface    */
1296     String newFile  = readFilename();
1297     if (newFile) {
1298         setLastEdit(newFile,0);
1299         if (readFilename()) {
1300             ERRMSG(0) "Multiple filenames not permitted"
1301             EEND;
1302         }
1303     }
1304     runEditor();
1305 }
1306
1307 static Void local find() {              /* edit file containing definition */
1308 #if 0
1309 This just plain wont work no more.
1310 ToDo: Fix!
1311     String nm = readFilename();         /* of specified name               */
1312     if (!nm) {
1313         ERRMSG(0) "No name specified"
1314         EEND;
1315     }
1316     else if (readFilename()) {
1317         ERRMSG(0) "Multiple names not permitted"
1318         EEND;
1319     }
1320     else {
1321         Text t;
1322         Cell c;
1323         setCurrModule(findEvalModule());
1324         startNewScript(0);
1325         if (nonNull(c=findTycon(t=findText(nm)))) {
1326             if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1327                 readScripts(1);
1328             }
1329         } else if (nonNull(c=findName(t))) {
1330             if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1331                 readScripts(1);
1332             }
1333         } else {
1334             ERRMSG(0) "No current definition for name \"%s\"", nm
1335             EEND;
1336         }
1337     }
1338 #endif
1339 }
1340
1341 static Void local runEditor() {         /* run editor on script lastEdit   */
1342     if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine              */
1343         readScripts(1);
1344 }
1345
1346 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1347 String fname;
1348 Int    line; {
1349     if (lastEdit)
1350         free(lastEdit);
1351     lastEdit = strCopy(fname);
1352     lastEdLine = line;
1353 #if HUGS_FOR_WINDOWS
1354     DrawStatusLine(hWndMain);           /* Redo status line                */
1355 #endif
1356 }
1357
1358 /* --------------------------------------------------------------------------
1359  * Read and evaluate an expression:
1360  * ------------------------------------------------------------------------*/
1361
1362 static Void local setModule(){/*set module in which to evaluate expressions*/
1363     String s = readFilename();
1364     if (!s) s = "";              /* :m clears the current module selection */
1365     evalModule = findText(s);
1366     setLastEdit(fileOfModule(findEvalModule()),0);
1367 }
1368
1369 static Module local findEvalModule() { /*Module in which to eval expressions*/
1370     Module m = findModule(evalModule);
1371     if (isNull(m))
1372         m = lastModule();
1373     return m;
1374 }
1375
1376 static Void local evaluator() {        /* evaluate expr and print value    */
1377     Type  type, bd;
1378     Kinds ks   = NIL;
1379
1380     setCurrModule(findEvalModule());
1381     scriptFile = 0;
1382     startNewScript(0);                 /* Enables recovery of storage      */
1383                                        /* allocated during evaluation      */
1384     parseExp();
1385     checkExp();
1386     defaultDefns = evalDefaults;
1387     type         = typeCheckExp(TRUE);
1388     if (isPolyType(type)) {
1389         ks = polySigOf(type);
1390         bd = monotypeOf(type);
1391     }
1392     else
1393         bd = type;
1394
1395     if (whatIs(bd)==QUAL) {
1396         ERRMSG(0) "Unresolved overloading" ETHEN
1397         ERRTEXT   "\n*** Type       : "    ETHEN ERRTYPE(type);
1398         ERRTEXT   "\n*** Expression : "    ETHEN ERREXPR(inputExpr);
1399         ERRTEXT   "\n"
1400         EEND;
1401     }
1402
1403 #ifdef WANT_TIMER
1404     updateTimers();
1405 #endif
1406
1407 #if 1
1408     if (isProgType(ks,bd)) {
1409         inputExpr = ap(nameRunIO_toplevel,inputExpr);
1410         evalExp();
1411         Putchar('\n');
1412     } else {
1413         Cell d = provePred(ks,NIL,ap(classShow,bd));
1414         if (isNull(d)) {
1415             ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1416             ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
1417             ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
1418             ERRTEXT   "\n"
1419             EEND;
1420         }
1421         inputExpr = ap2(findName(findText("show")),d,inputExpr);
1422         inputExpr = ap(findName(findText("putStr")), inputExpr);
1423         inputExpr = ap(nameRunIO_toplevel, inputExpr);
1424
1425         evalExp(); printf("\n");
1426         if (addType) {
1427             printf(" :: ");
1428             printType(stdout,type);
1429             Putchar('\n');
1430         }
1431     }
1432
1433 #else
1434
1435    printf ( "result type is " );
1436    printType ( stdout, type );
1437    printf ( "\n" );
1438    evalExp();
1439    printf ( "\n" );
1440
1441 #endif
1442
1443 }
1444
1445 static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
1446     if (printing) {                    /* after successful termination or  */
1447         printing = FALSE;              /* runtime error (e.g. interrupt)   */
1448         Putchar('\n');
1449         if (showStats) {
1450 #define plural(v)   v, (v==1?"":"s")
1451             Printf("%lu cell%s",plural(numCells));
1452             if (numGcs>0)
1453                 Printf(", %u garbage collection%s",plural(numGcs));
1454             Printf(")\n");
1455 #undef plural
1456         }
1457         FlushStdout();
1458         garbageCollect();
1459     }
1460 }
1461
1462 /* --------------------------------------------------------------------------
1463  * Print type of input expression:
1464  * ------------------------------------------------------------------------*/
1465
1466 static Void local showtype() {         /* print type of expression (if any)*/
1467     Cell type;
1468
1469     setCurrModule(findEvalModule());
1470     startNewScript(0);                 /* Enables recovery of storage      */
1471                                        /* allocated during evaluation      */
1472     parseExp();
1473     checkExp();
1474     defaultDefns = evalDefaults;
1475     type = typeCheckExp(FALSE);
1476     printExp(stdout,inputExpr);
1477     Printf(" :: ");
1478     printType(stdout,type);
1479     Putchar('\n');
1480 }
1481
1482
1483 static Void local browseit(mod,t,all)
1484 Module mod;
1485 String t;
1486 Bool all; {
1487     if (nonNull(mod)) {
1488         Cell cs;
1489         if (nonNull(t))
1490             Printf("module %s where\n",textToStr(module(mod).text));
1491         for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1492             Name nm = hd(cs);
1493             /* only look at things defined in this module,
1494                unless `all' flag is set */
1495             if (all || name(nm).mod == mod) {
1496                 /* unwanted artifacts, like lambda lifted values,
1497                    are in the list of names, but have no types */
1498                 if (nonNull(name(nm).type)) {
1499                     printExp(stdout,nm);
1500                     Printf(" :: ");
1501                     printType(stdout,name(nm).type);
1502                     if (isCfun(nm)) {
1503                         Printf("  -- data constructor");
1504                     } else if (isMfun(nm)) {
1505                         Printf("  -- class member");
1506                     } else if (isSfun(nm)) {
1507                         Printf("  -- selector function");
1508                     }
1509                     Printf("\n");
1510                 }
1511             }
1512         }
1513     } else {
1514       if (isNull(mod)) {
1515         Printf("Unknown module %s\n",t);
1516       }
1517     }
1518 }
1519
1520 static Void local browse() {            /* browse modules                  */
1521     Int    count = 0;                   /* or give menu of commands        */
1522     String s;
1523     Bool all = FALSE;
1524
1525     setCurrModule(findEvalModule());
1526     startNewScript(0);                  /* for recovery of storage         */
1527     for (; (s=readFilename())!=0; count++)
1528         if (strcmp(s,"all") == 0) {
1529             all = TRUE;
1530             --count;
1531         } else
1532             browseit(findModule(findText(s)),s,all);
1533     if (count == 0) {
1534         browseit(findEvalModule(),NULL,all);
1535     }
1536 }
1537
1538 #if EXPLAIN_INSTANCE_RESOLUTION
1539 static Void local xplain() {         /* print type of expression (if any)*/
1540     Cell d;
1541     Bool sir = showInstRes;
1542
1543     setCurrModule(findEvalModule());
1544     startNewScript(0);                 /* Enables recovery of storage      */
1545                                        /* allocated during evaluation      */
1546     parseContext();
1547     checkContext();
1548     showInstRes = TRUE;
1549     d = provePred(NIL,NIL,hd(inputContext));
1550     if (isNull(d)) {
1551         fprintf(stdout, "not Sat\n");
1552     } else {
1553         fprintf(stdout, "Sat\n");
1554     }
1555     showInstRes = sir;
1556 }
1557 #endif
1558
1559 /* --------------------------------------------------------------------------
1560  * Enhanced help system:  print current list of scripts or give information
1561  * about an object.
1562  * ------------------------------------------------------------------------*/
1563
1564 static String local objToStr(m,c)
1565 Module m;
1566 Cell   c; {
1567 #if 1 || DISPLAY_QUANTIFIERS
1568     static char newVar[60];
1569     switch (whatIs(c)) {
1570         case NAME  : if (m == name(c).mod) {
1571                          sprintf(newVar,"%s", textToStr(name(c).text));
1572                      } else {
1573                          sprintf(newVar,"%s.%s",
1574                                         textToStr(module(name(c).mod).text),
1575                                         textToStr(name(c).text));
1576                      }
1577                      break;
1578
1579         case TYCON : if (m == tycon(c).mod) {
1580                          sprintf(newVar,"%s", textToStr(tycon(c).text));
1581                      } else {
1582                          sprintf(newVar,"%s.%s",
1583                                         textToStr(module(tycon(c).mod).text),
1584                                         textToStr(tycon(c).text));
1585                      }
1586                      break;
1587
1588         case CLASS : if (m == cclass(c).mod) {
1589                          sprintf(newVar,"%s", textToStr(cclass(c).text));
1590                      } else {
1591                          sprintf(newVar,"%s.%s",
1592                                         textToStr(module(cclass(c).mod).text),
1593                                         textToStr(cclass(c).text));
1594                      }
1595                      break;
1596
1597         default    : internal("objToStr");
1598     }
1599     return newVar;
1600 #else
1601     static char newVar[33];
1602     switch (whatIs(c)) {
1603         case NAME  : sprintf(newVar,"%s", textToStr(name(c).text));
1604                      break;
1605
1606         case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1607                      break;
1608
1609         case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1610                      break;
1611
1612         default    : internal("objToStr");
1613     }
1614     return newVar;
1615 #endif
1616 }
1617
1618 extern Name nameHw;
1619
1620 static Void local dumpStg( void ) {       /* print STG stuff                 */
1621     String s;
1622     Text   t;
1623     Name   n;
1624     Int    i;
1625     Cell   v;                           /* really StgVar */
1626     setCurrModule(findEvalModule());
1627     startNewScript(0);
1628     for (; (s=readFilename())!=0;) {
1629         t = findText(s);
1630         v = n = NIL;
1631         /* find the name while ignoring module scopes */
1632         for (i=NAMEMIN; i<nameHw; i++)
1633            if (name(i).text == t) n = i;
1634
1635         /* perhaps it's an "idNNNNNN" thing? */
1636         if (isNull(n) &&
1637             strlen(s) >= 3 &&
1638             s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1639            v = 0;
1640            i = 2;
1641            while (isdigit(s[i])) {
1642               v = v * 10 + (s[i]-'0');
1643               i++;
1644            }
1645            v = -v;
1646            n = nameFromStgVar(v);
1647         }
1648
1649         if (isNull(n) && whatIs(v)==STGVAR) {
1650            Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1651            printStg(stderr, v );
1652         } else
1653         if (isNull(n)) {
1654            Printf ( "Unknown reference `%s'\n", s );
1655         } else
1656         if (!isName(n)) {
1657            Printf ( "Not a Name: `%s'\n", s );
1658         } else
1659         if (isNull(name(n).stgVar)) {
1660            Printf ( "Doesn't have a STG tree: %s\n", s );
1661         } else {
1662            Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1663            printStg(stderr, name(n).stgVar);
1664         }
1665     }
1666 }
1667
1668 static Void local info() {              /* describe objects                */
1669     Int    count = 0;                   /* or give menu of commands        */
1670     String s;
1671
1672     setCurrModule(findEvalModule());
1673     startNewScript(0);                  /* for recovery of storage         */
1674     for (; (s=readFilename())!=0; count++) {
1675         describe(findText(s));
1676     }
1677     if (count == 0) {
1678         whatScripts();
1679     }
1680 }
1681
1682
1683 static Void local describe(t)           /* describe an object              */
1684 Text t; {
1685     Tycon  tc  = findTycon(t);
1686     Class  cl  = findClass(t);
1687     Name   nm  = findName(t);
1688
1689     if (nonNull(tc)) {                  /* as a type constructor           */
1690         Type t = tc;
1691         Int  i;
1692         Inst in;
1693         for (i=0; i<tycon(tc).arity; ++i) {
1694             t = ap(t,mkOffset(i));
1695         }
1696         Printf("-- type constructor");
1697         if (kindExpert) {
1698             Printf(" with kind ");
1699             printKind(stdout,tycon(tc).kind);
1700         }
1701         Putchar('\n');
1702         switch (tycon(tc).what) {
1703             case SYNONYM      : Printf("type ");
1704                                 printType(stdout,t);
1705                                 Printf(" = ");
1706                                 printType(stdout,tycon(tc).defn);
1707                                 break;
1708
1709             case NEWTYPE      :
1710             case DATATYPE     : {   List cs = tycon(tc).defn;
1711                                     if (tycon(tc).what==DATATYPE) {
1712                                         Printf("data ");
1713                                     } else {
1714                                         Printf("newtype ");
1715                                     }
1716                                     printType(stdout,t);
1717                                     Putchar('\n');
1718                                     mapProc(printSyntax,cs);
1719                                     if (hasCfun(cs)) {
1720                                         Printf("\n-- constructors:");
1721                                     }
1722                                     for (; hasCfun(cs); cs=tl(cs)) {
1723                                         Putchar('\n');
1724                                         printExp(stdout,hd(cs));
1725                                         Printf(" :: ");
1726                                         printType(stdout,name(hd(cs)).type);
1727                                     }
1728                                     if (nonNull(cs)) {
1729                                         Printf("\n-- selectors:");
1730                                     }
1731                                     for (; nonNull(cs); cs=tl(cs)) {
1732                                         Putchar('\n');
1733                                         printExp(stdout,hd(cs));
1734                                         Printf(" :: ");
1735                                         printType(stdout,name(hd(cs)).type);
1736                                     }
1737                                 }
1738                                 break;
1739
1740             case RESTRICTSYN  : Printf("type ");
1741                                 printType(stdout,t);
1742                                 Printf(" = <restricted>");
1743                                 break;
1744         }
1745         Putchar('\n');
1746         if (nonNull(in=findFirstInst(tc))) {
1747             Printf("\n-- instances:\n");
1748             do {
1749                 showInst(in);
1750                 in = findNextInst(tc,in);
1751             } while (nonNull(in));
1752         }
1753         Putchar('\n');
1754     }
1755
1756     if (nonNull(cl)) {                  /* as a class                      */
1757         List  ins = cclass(cl).instances;
1758         Kinds ks  = cclass(cl).kinds;
1759         if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1760             Printf("-- type class");
1761         } else {
1762             Printf("-- constructor class");
1763             if (kindExpert) {
1764                 Printf(" with arity ");
1765                 printKinds(stdout,ks);
1766             }
1767         }
1768         Putchar('\n');
1769         mapProc(printSyntax,cclass(cl).members);
1770         Printf("class ");
1771         if (nonNull(cclass(cl).supers)) {
1772             printContext(stdout,cclass(cl).supers);
1773             Printf(" => ");
1774         }
1775         printPred(stdout,cclass(cl).head);
1776
1777         if (nonNull(cclass(cl).fds)) {
1778             List   fds = cclass(cl).fds;
1779             String pre = " | ";
1780             for (; nonNull(fds); fds=tl(fds)) {
1781                 Printf(pre);
1782                 printFD(stdout,hd(fds));
1783                 pre = ", ";
1784             }
1785         }
1786
1787         if (nonNull(cclass(cl).members)) {
1788             List ms = cclass(cl).members;
1789             Printf(" where");
1790             do {
1791                 Type t = name(hd(ms)).type;
1792                 if (isPolyType(t)) {
1793                     t = monotypeOf(t);
1794                 }
1795                 Printf("\n  ");
1796                 printExp(stdout,hd(ms));
1797                 Printf(" :: ");
1798                 if (isNull(tl(fst(snd(t))))) {
1799                     t = snd(snd(t));
1800                 } else {
1801                     t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1802                 }
1803                 printType(stdout,t);
1804                 ms = tl(ms);
1805             } while (nonNull(ms));
1806         }
1807         Putchar('\n');
1808         if (nonNull(ins)) {
1809             Printf("\n-- instances:\n");
1810             do {
1811                 showInst(hd(ins));
1812                 ins = tl(ins);
1813             } while (nonNull(ins));
1814         }
1815         Putchar('\n');
1816     }
1817
1818     if (nonNull(nm)) {                  /* as a function/name              */
1819         printSyntax(nm);
1820         printExp(stdout,nm);
1821         Printf(" :: ");
1822         if (nonNull(name(nm).type)) {
1823             printType(stdout,name(nm).type);
1824         } else {
1825             Printf("<unknown type>");
1826         }
1827 printf("\n");print(name(nm).type,10);printf("\n");
1828         if (isCfun(nm)) {
1829             Printf("  -- data constructor");
1830         } else if (isMfun(nm)) {
1831             Printf("  -- class member");
1832         } else if (isSfun(nm)) {
1833             Printf("  -- selector function");
1834         }
1835         Printf("\n\n");
1836     }
1837
1838
1839     if (isNull(tc) && isNull(cl) && isNull(nm)) {
1840         Printf("Unknown reference `%s'\n",textToStr(t));
1841     }
1842 }
1843
1844 static Void local printSyntax(nm)
1845 Name nm; {
1846     Syntax sy = syntaxOf(nm);
1847     Text   t  = name(nm).text;
1848     String s  = textToStr(t);
1849     if (sy != defaultSyntax(t)) {
1850         Printf("infix");
1851         switch (assocOf(sy)) {
1852             case LEFT_ASS  : Putchar('l'); break;
1853             case RIGHT_ASS : Putchar('r'); break;
1854             case NON_ASS   : break;
1855         }
1856         Printf(" %i ",precOf(sy));
1857         if (isascii((int)(*s)) && isalpha((int)(*s))) {
1858             Printf("`%s`",s);
1859         } else {
1860             Printf("%s",s);
1861         }
1862         Putchar('\n');
1863     }
1864 }
1865
1866 static Void local showInst(in)          /* Display instance decl header    */
1867 Inst in; {
1868     Printf("instance ");
1869     if (nonNull(inst(in).specifics)) {
1870         printContext(stdout,inst(in).specifics);
1871         Printf(" => ");
1872     }
1873     printPred(stdout,inst(in).head);
1874     Putchar('\n');
1875 }
1876
1877 /* --------------------------------------------------------------------------
1878  * List all names currently in scope:
1879  * ------------------------------------------------------------------------*/
1880
1881 static Void local listNames() {         /* list names matching optional pat*/
1882     String pat   = readFilename();
1883     List   names = NIL;
1884     Int    width = getTerminalWidth() - 1;
1885     Int    count = 0;
1886     Int    termPos;
1887     Module mod   = findEvalModule();
1888
1889     if (pat) {                          /* First gather names to list      */
1890         do {
1891             names = addNamesMatching(pat,names);
1892         } while ((pat=readFilename())!=0);
1893     } else {
1894         names = addNamesMatching((String)0,names);
1895     }
1896     if (isNull(names)) {                /* Then print them out             */
1897         ERRMSG(0) "No names selected"
1898         EEND;
1899     }
1900     for (termPos=0; nonNull(names); names=tl(names)) {
1901         String s = objToStr(mod,hd(names));
1902         Int    l = strlen(s);
1903         if (termPos+1+l>width) {
1904             Putchar('\n');
1905             termPos = 0;
1906         } else if (termPos>0) {
1907             Putchar(' ');
1908             termPos++;
1909         }
1910         Printf("%s",s);
1911         termPos += l;
1912         count++;
1913     }
1914     Printf("\n(%d names listed)\n", count);
1915 }
1916
1917 /* --------------------------------------------------------------------------
1918  * print a prompt and read a line of input:
1919  * ------------------------------------------------------------------------*/
1920
1921 static Void local promptForInput(moduleName)
1922 String moduleName; {
1923     char promptBuffer[1000];
1924 #if 1
1925     /* This is portable but could overflow buffer */
1926     sprintf(promptBuffer,prompt,moduleName);
1927 #else
1928     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1929      * promptBuffer instead.
1930      */
1931     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1932         /* Reset prompt to a safe default to avoid an infinite loop */
1933         free(prompt);
1934         prompt = strCopy("? ");
1935         internal("Combined prompt and evaluation module name too long");
1936     }
1937 #endif
1938     if (autoMain)
1939        stringInput("main\0"); else
1940        consoleInput(promptBuffer);
1941 }
1942
1943 /* --------------------------------------------------------------------------
1944  * main read-eval-print loop, with error trapping:
1945  * ------------------------------------------------------------------------*/
1946
1947 static jmp_buf catch_error;             /* jump buffer for error trapping  */
1948
1949 static Void local interpreter(argc,argv)/* main interpreter loop           */
1950 Int    argc;
1951 String argv[]; {
1952     Int errorNumber = setjmp(catch_error);
1953
1954     if (errorNumber && autoMain) {
1955        fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
1956        exit(1);
1957     }
1958
1959     breakOn(TRUE);                      /* enable break trapping           */
1960     if (numScripts==0) {                /* only succeeds on first time,    */
1961         if (errorNumber)                /* before prelude has been loaded  */
1962             fatal("Unable to load prelude");
1963         initialize(argc,argv);
1964         forHelp();
1965     }
1966
1967     /* initialize calls startupHaskell, which trashes our signal handlers */
1968     breakOn(TRUE);
1969
1970     for (;;) {
1971         Command cmd;
1972         everybody(RESET);               /* reset to sensible initial state */
1973         dropScriptsFrom(numScripts-1);  /* remove partially loaded scripts */
1974                                         /* not counting prelude as a script*/
1975
1976         promptForInput(textToStr(module(findEvalModule()).text));
1977
1978         cmd = readCommand(cmds, (Char)':', (Char)'!');
1979 #ifdef WANT_TIMER
1980         updateTimers();
1981 #endif
1982         switch (cmd) {
1983             case EDIT   : editor();
1984                           break;
1985             case FIND   : find();
1986                           break;
1987             case LOAD   : clearProject();
1988                           forgetScriptsFrom(1);
1989                           load();
1990                           break;
1991             case ALSO   : clearProject();
1992                           forgetScriptsFrom(numScripts);
1993                           load();
1994                           break;
1995             case RELOAD : readScripts(1);
1996                           break;
1997             case PROJECT: project();
1998                           break;
1999             case SETMODULE :
2000                           setModule();
2001                           break;
2002             case EVAL   : evaluator();
2003                           break;
2004             case TYPEOF : showtype();
2005                           break;
2006             case BROWSE : browse();
2007                           break;
2008 #if EXPLAIN_INSTANCE_RESOLUTION
2009             case XPLAIN : xplain();
2010                           break;
2011 #endif
2012             case NAMES  : listNames();
2013                           break;
2014             case HELP   : menu();
2015                           break;
2016             case BADCMD : guidance();
2017                           break;
2018             case SET    : set();
2019                           break;
2020             case STATS:
2021 #ifdef CRUDE_PROFILING
2022                           cp_show();
2023 #endif
2024                           break;
2025             case SYSTEM : if (shellEsc(readLine()))
2026                               Printf("Warning: Shell escape terminated abnormally\n");
2027                           break;
2028             case CHGDIR : changeDir();
2029                           break;
2030             case INFO   : info();
2031                           break;
2032             case PNTVER: Printf("-- Hugs Version %s\n",
2033                                  HUGS_VERSION);
2034                           break;
2035             case DUMP   : dumpStg();
2036                           break;
2037             case QUIT   : return;
2038             case COLLECT: consGC = FALSE;
2039                           garbageCollect();
2040                           consGC = TRUE;
2041                           Printf("Garbage collection recovered %d cells\n",
2042                                  cellsRecovered);
2043                           break;
2044             case NOCMD  : break;
2045         }
2046 #ifdef WANT_TIMER
2047         updateTimers();
2048         Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
2049                millisecs(userElapsed), millisecs(systElapsed));
2050 #endif
2051         if (autoMain) break;
2052     }
2053     breakOn(FALSE);
2054 }
2055
2056 /* --------------------------------------------------------------------------
2057  * Display progress towards goal:
2058  * ------------------------------------------------------------------------*/
2059
2060 static Target currTarget;
2061 static Bool   aiming = FALSE;
2062 static Int    currPos;
2063 static Int    maxPos;
2064 static Int    charCount;
2065
2066 Void setGoal(what, t)                  /* Set goal for what to be t        */
2067 String what;
2068 Target t; {
2069     if (quiet)
2070       return;
2071 #if EXPLAIN_INSTANCE_RESOLUTION
2072     if (showInstRes)
2073       return;
2074 #endif
2075     currTarget = (t?t:1);
2076     aiming     = TRUE;
2077     if (useDots) {
2078         currPos = strlen(what);
2079         maxPos  = getTerminalWidth() - 1;
2080         Printf("%s",what);
2081     }
2082     else
2083         for (charCount=0; *what; charCount++)
2084             Putchar(*what++);
2085     FlushStdout();
2086 }
2087
2088 Void soFar(t)                          /* Indicate progress towards goal   */
2089 Target t; {                            /* has now reached t                */
2090     if (quiet)
2091       return;
2092 #if EXPLAIN_INSTANCE_RESOLUTION
2093     if (showInstRes)
2094       return;
2095 #endif
2096     if (useDots) {
2097         Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2098
2099         if (newPos>maxPos)
2100             newPos = maxPos;
2101
2102         if (newPos>currPos) {
2103             do
2104                 Putchar('.');
2105             while (newPos>++currPos);
2106             FlushStdout();
2107         }
2108         FlushStdout();
2109     }
2110 }
2111
2112 Void done() {                          /* Goal has now been achieved       */
2113     if (quiet)
2114       return;
2115 #if EXPLAIN_INSTANCE_RESOLUTION
2116     if (showInstRes)
2117       return;
2118 #endif
2119     if (useDots) {
2120         while (maxPos>currPos++)
2121             Putchar('.');
2122         Putchar('\n');
2123     }
2124     else
2125         for (; charCount>0; charCount--) {
2126             Putchar('\b');
2127             Putchar(' ');
2128             Putchar('\b');
2129         }
2130     aiming = FALSE;
2131     FlushStdout();
2132 }
2133
2134 static Void local failed() {           /* Goal cannot be reached due to    */
2135     if (aiming) {                      /* errors                           */
2136         aiming = FALSE;
2137         Putchar('\n');
2138         FlushStdout();
2139     }
2140 }
2141
2142 /* --------------------------------------------------------------------------
2143  * Error handling:
2144  * ------------------------------------------------------------------------*/
2145
2146 Void errHead(l)                        /* print start of error message     */
2147 Int l; {
2148     failed();                          /* failed to reach target ...       */
2149     stopAnyPrinting();
2150     FPrintf(errorStream,"ERROR");
2151
2152     if (scriptFile) {
2153         FPrintf(errorStream," \"%s\"", scriptFile);
2154         setLastEdit(scriptFile,l);
2155         if (l) FPrintf(errorStream," (line %d)",l);
2156         scriptFile = 0;
2157     }
2158     FPrintf(errorStream,": ");
2159     FFlush(errorStream);
2160 }
2161
2162 Void errFail() {                        /* terminate error message and     */
2163     Putc('\n',errorStream);             /* produce exception to return to  */
2164     FFlush(errorStream);                /* main command loop               */
2165     longjmp(catch_error,1);
2166 }
2167
2168 Void errAbort() {                       /* altern. form of error handling  */
2169     failed();                           /* used when suitable error message*/
2170     stopAnyPrinting();                  /* has already been printed        */
2171     errFail();
2172 }
2173
2174 Void internal(msg)                      /* handle internal error           */
2175 String msg; {
2176 #if HUGS_FOR_WINDOWS
2177     char buf[300];
2178     wsprintf(buf,"INTERNAL ERROR: %s",msg);
2179     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2180 #endif
2181     failed();
2182     stopAnyPrinting();
2183     Printf("INTERNAL ERROR: %s\n",msg);
2184     FlushStdout();
2185     longjmp(catch_error,1);
2186 }
2187
2188 Void fatal(msg)                         /* handle fatal error              */
2189 String msg; {
2190 #if HUGS_FOR_WINDOWS
2191     char buf[300];
2192     wsprintf(buf,"FATAL ERROR: %s",msg);
2193     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2194 #endif
2195     FlushStdout();
2196     Printf("\nFATAL ERROR: %s\n",msg);
2197     everybody(EXIT);
2198     exit(1);
2199 }
2200
2201 sigHandler(breakHandler) {              /* respond to break interrupt      */
2202 #if HUGS_FOR_WINDOWS
2203     MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
2204 #endif
2205     Hilite();
2206     Printf("{Interrupted!}\n");
2207     Lolite();
2208     breakOn(TRUE);  /* reinstall signal handler - redundant on BSD systems */
2209                     /* but essential on POSIX (and other?) systems         */
2210     everybody(BREAK);
2211     failed();
2212     stopAnyPrinting();
2213     FlushStdout();
2214     clearerr(stdin);
2215     longjmp(catch_error,1);
2216     sigResume;/*NOTREACHED*/
2217 }
2218
2219 /* --------------------------------------------------------------------------
2220  * Read value from environment variable or registry:
2221  * ------------------------------------------------------------------------*/
2222
2223 String fromEnv(var,def)         /* return value of:                        */
2224 String var;                     /*     environment variable named by var   */
2225 String def; {                   /* or: default value given by def          */
2226     String s = getenv(var);
2227     return (s ? s : def);
2228 }
2229
2230 /* --------------------------------------------------------------------------
2231  * String manipulation routines:
2232  * ------------------------------------------------------------------------*/
2233
2234 static String local strCopy(s)         /* make malloced copy of a string   */
2235 String s; {
2236     if (s && *s) {
2237         char *t, *r;
2238         if ((t=(char *)malloc(strlen(s)+1))==0) {
2239             ERRMSG(0) "String storage space exhausted"
2240             EEND;
2241         }
2242         for (r=t; (*r++ = *s++)!=0; ) {
2243         }
2244         return t;
2245     }
2246     return NULL;
2247 }
2248
2249 /* --------------------------------------------------------------------------
2250  * Compiler output
2251  * We can redirect compiler output (prompts, error messages, etc) by
2252  * tweaking these functions.
2253  * ------------------------------------------------------------------------*/
2254
2255 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2256
2257 #ifdef HAVE_STDARG_H
2258 #include <stdarg.h>
2259 #else
2260 #include <varargs.h>
2261 #endif
2262
2263 /* ----------------------------------------------------------------------- */
2264
2265 #define BufferSize 10000              /* size of redirected output buffer  */
2266
2267 typedef struct _HugsStream {
2268     char buffer[BufferSize];          /* buffer for redirected output      */
2269     Int  next;                        /* next space in buffer              */
2270 } HugsStream;
2271
2272 static Void   local vBufferedPrintf  Args((HugsStream*, const char*, va_list));
2273 static Void   local bufferedPutchar  Args((HugsStream*, Char));
2274 static String local bufferClear      Args((HugsStream *stream));
2275
2276 static Void local vBufferedPrintf(stream, fmt, ap)
2277 HugsStream* stream;
2278 const char* fmt;
2279 va_list     ap; {
2280     Int spaceLeft = BufferSize - stream->next;
2281     char* p = &stream->buffer[stream->next];
2282     Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2283     if (0 <= charsAdded && charsAdded < spaceLeft)
2284         stream->next += charsAdded;
2285 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2286     else
2287         stream->next = 0;
2288 #endif
2289 }
2290
2291 static Void local bufferedPutchar(stream, c)
2292 HugsStream *stream;
2293 Char        c; {
2294     if (BufferSize - stream->next >= 2) {
2295         stream->buffer[stream->next++] = c;
2296         stream->buffer[stream->next] = '\0';
2297     }
2298 }
2299
2300 static String local bufferClear(stream)
2301 HugsStream *stream; {
2302     if (stream->next == 0) {
2303         return "";
2304     } else {
2305         stream->next = 0;
2306         return stream->buffer;
2307     }
2308 }
2309
2310 /* ----------------------------------------------------------------------- */
2311
2312 static HugsStream outputStreamH;
2313 /* ADR note:
2314  * We rely on standard C semantics to initialise outputStreamH.next to 0.
2315  */
2316
2317 Void hugsEnableOutput(f)
2318 Bool f; {
2319     disableOutput = !f;
2320 }
2321
2322 String hugsClearOutputBuffer() {
2323     return bufferClear(&outputStreamH);
2324 }
2325
2326 #ifdef HAVE_STDARG_H
2327 Void hugsPrintf(const char *fmt, ...) {
2328     va_list ap;                    /* pointer into argument list           */
2329     va_start(ap, fmt);             /* make ap point to first arg after fmt */
2330     if (!disableOutput) {
2331         vprintf(fmt, ap);
2332     } else {
2333         vBufferedPrintf(&outputStreamH, fmt, ap);
2334     }
2335     va_end(ap);                    /* clean up                             */
2336 }
2337 #else
2338 Void hugsPrintf(fmt, va_alist)
2339 const char *fmt;
2340 va_dcl {
2341     va_list ap;                    /* pointer into argument list           */
2342     va_start(ap);                  /* make ap point to first arg after fmt */
2343     if (!disableOutput) {
2344         vprintf(fmt, ap);
2345     } else {
2346         vBufferedPrintf(&outputStreamH, fmt, ap);
2347     }
2348     va_end(ap);                    /* clean up                             */
2349 }
2350 #endif
2351
2352 Void hugsPutchar(c)
2353 int c; {
2354     if (!disableOutput) {
2355         putchar(c);
2356     } else {
2357         bufferedPutchar(&outputStreamH, c);
2358     }
2359 }
2360
2361 Void hugsFlushStdout() {
2362     if (!disableOutput) {
2363         fflush(stdout);
2364     }
2365 }
2366
2367 Void hugsFFlush(fp)
2368 FILE* fp; {
2369     if (!disableOutput) {
2370         fflush(fp);
2371     }
2372 }
2373
2374 #ifdef HAVE_STDARG_H
2375 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2376     va_list ap;
2377     va_start(ap, fmt);
2378     if (!disableOutput) {
2379         vfprintf(fp, fmt, ap);
2380     } else {
2381         vBufferedPrintf(&outputStreamH, fmt, ap);
2382     }
2383     va_end(ap);
2384 }
2385 #else
2386 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2387 FILE* fp;
2388 const char* fmt;
2389 va_dcl {
2390     va_list ap;
2391     va_start(ap);
2392     if (!disableOutput) {
2393         vfprintf(fp, fmt, ap);
2394     } else {
2395         vBufferedPrintf(&outputStreamH, fmt, ap);
2396     }
2397     va_end(ap);
2398 }
2399 #endif
2400
2401 Void hugsPutc(c, fp)
2402 int   c;
2403 FILE* fp; {
2404     if (!disableOutput) {
2405         putc(c,fp);
2406     } else {
2407         bufferedPutchar(&outputStreamH, c);
2408     }
2409 }
2410
2411 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2412 /* --------------------------------------------------------------------------
2413  * Send message to each component of system:
2414  * ------------------------------------------------------------------------*/
2415
2416 Void everybody(what)            /* send command `what' to each component of*/
2417 Int what; {                     /* system to respond as appropriate ...    */
2418 #if 0
2419   fprintf ( stderr, "EVERYBODY %d\n", what );
2420 #endif
2421     machdep(what);              /* The order of calling each component is  */
2422     storage(what);              /* important for the PREPREL command       */
2423     substitution(what);
2424     input(what);
2425     translateControl(what);
2426     linkControl(what);
2427     staticAnalysis(what);
2428     deriveControl(what);
2429     typeChecker(what);
2430     compiler(what);
2431     codegen(what);
2432 }
2433
2434 /* --------------------------------------------------------------------------
2435  * Hugs for Windows code (WinMain and related functions)
2436  * ------------------------------------------------------------------------*/
2437
2438 #if HUGS_FOR_WINDOWS
2439 #include "winhugs.c"
2440 #endif