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.44 $
  13  * $Date: 2000/03/15 23:27:16 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include <setjmp.h>
  17 #include <ctype.h>
  18 #include <stdio.h>
  19
  20 #include "prelude.h"
  21 #include "storage.h"
  22 #include "connect.h"
  23 #include "errors.h"
  24 #include "version.h"
  25
  26 #include "Rts.h"
  27 #include "RtsAPI.h"
  28 #include "Schedule.h"
  29 #include "Assembler.h"                                /* DEBUG_LoadSymbols */
  30
  31 Bool haskell98 = TRUE;                  /* TRUE => Haskell 98 compatibility*/
  32
  33 #if EXPLAIN_INSTANCE_RESOLUTION
  34 Bool showInstRes = FALSE;
  35 #endif
  36 #if MULTI_INST
  37 Bool multiInstRes = FALSE;
  38 #endif
  39
  40 /* --------------------------------------------------------------------------
  41  * Local function prototypes:
  42  * ------------------------------------------------------------------------*/
  43
  44 static Void   local initialize        ( Int,String [] );
  45 static Void   local promptForInput    ( String );
  46 static Void   local interpreter       ( Int,String [] );
  47 static Void   local menu              ( Void );
  48 static Void   local guidance          ( Void );
  49 static Void   local forHelp           ( Void );
  50 static Void   local set               ( Void );
  51 static Void   local changeDir         ( Void );
  52 static Void   local load              ( Void );
  53 static Void   local project           ( Void );
  54 static Void   local readScripts       ( Int );
  55 static Void   local whatScripts       ( Void );
  56 static Void   local editor            ( Void );
  57 static Void   local find              ( Void );
  58 static Bool   local startEdit         ( Int,String );
  59 static Void   local runEditor         ( Void );
  60 static Void   local setModule         ( Void );
  61 static Module local findEvalModule    ( Void );
  62 static Void   local evaluator         ( Void );
  63 static Void   local stopAnyPrinting   ( Void );
  64 static Void   local showtype          ( Void );
  65 static String local objToStr          ( Module, Cell );
  66 static Void   local info              ( Void );
  67 static Void   local printSyntax       ( Name );
  68 static Void   local showInst          ( Inst );
  69 static Void   local describe          ( Text );
  70 static Void   local listNames         ( Void );
  71
  72 static Void   local toggleSet         ( Char,Bool );
  73 static Void   local togglesIn         ( Bool );
  74 static Void   local optionInfo        ( Void );
  75 #if USE_REGISTRY || HUGS_FOR_WINDOWS
  76 static String local optionsToStr      ( Void );
  77 #endif
  78 static Void   local readOptions       ( String );
  79 static Bool   local processOption     ( String );
  80 static Void   local setHeapSize       ( String );
  81 static Int    local argToInt          ( String );
  82
  83 static Void   local loadProject       ( String );
  84 static Void   local clearProject      ( Void );
  85 static Bool   local addScript         ( Int );
  86 static Void   local forgetScriptsFrom ( Script );
  87 static Void   local setLastEdit       ( String,Int );
  88 static Void   local failed            ( Void );
  89 static String local strCopy           ( String );
  90 static Void   local browseit          ( Module,String,Bool );
  91 static Void   local browse            ( Void );
  92
  93 /* --------------------------------------------------------------------------
  94  * Machine dependent code for Hugs interpreter:
  95  * ------------------------------------------------------------------------*/
  96
  97 #include "machdep.c"
  98 #ifdef WANT_TIMER
  99 #include "timer.c"
 100 #endif
 101
 102 /* --------------------------------------------------------------------------
 103  * Local data areas:
 104  * ------------------------------------------------------------------------*/
 105
 106 static Bool   printing      = FALSE;    /* TRUE => currently printing value*/
 107 static Bool   showStats     = FALSE;    /* TRUE => print stats after eval  */
 108 static Bool   listScripts   = TRUE;   /* TRUE => list scripts after loading*/
 109 static Bool   addType       = FALSE;    /* TRUE => print type with value   */
 110 static Bool   useDots       = RISCOS;   /* TRUE => use dots in progress    */
 111 static Bool   quiet         = FALSE;    /* TRUE => don't show progress     */
 112 static Bool   lastWasObject = FALSE;
 113
 114        Bool   flagAssert    = FALSE;    /* TRUE => assert False <e> causes
 115                                                    an assertion failure    */
 116        Bool   preludeLoaded = FALSE;
 117        Bool   debugSC       = FALSE;
 118        Bool   combined      = FALSE;
 119
 120 typedef
 121    struct {
 122       String modName;                   /* Module name                     */
 123       Bool   details;             /* FALSE => remaining fields are invalid */
 124       String path;                      /* Path to module                  */
 125       String srcExt;                    /* ".hs" or ".lhs" if fromSource   */
 126       Time   lastChange;                /* Time of last change to script   */
 127       Bool   fromSource;                /* FALSE => load object code       */
 128       Bool   postponed;                 /* Indicates postponed load        */
 129       Bool   objLoaded;
 130       Long   size;
 131       Long   oSize;
 132    }
 133    ScriptInfo;
 134
 135 static Void   local makeStackEntry    ( ScriptInfo*,String );
 136 static Void   local addStackEntry     ( String );
 137
 138 static ScriptInfo scriptInfo[NUM_SCRIPTS];
 139
 140 static Int    numScripts;               /* Number of scripts loaded        */
 141 static Int    nextNumScripts;
 142 static Int    namesUpto;                /* Number of script names set      */
 143 static Bool   needsImports;             /* set to TRUE if imports required */
 144        String scriptFile;               /* Name of current script (if any) */
 145
 146
 147
 148 static Text   evalModule  = 0;          /* Name of module we eval exprs in */
 149 static String currProject = 0;          /* Name of current project file    */
 150 static Bool   projectLoaded = FALSE;    /* TRUE => project file loaded     */
 151
 152 static Bool   autoMain   = FALSE;
 153 static String lastEdit   = 0;           /* Name of script to edit (if any) */
 154 static Int    lastEdLine = 0;           /* Editor line number (if possible)*/
 155 static String prompt     = 0;           /* Prompt string                   */
 156 static Int    hpSize     = DEFAULTHEAP; /* Desired heap size               */
 157        String hugsEdit   = 0;           /* String for editor command       */
 158        String hugsPath   = 0;           /* String for file search path     */
 159
 160        List  ifaces_outstanding = NIL;
 161
 162 #if REDIRECT_OUTPUT
 163 static Bool disableOutput = FALSE;      /* redirect output to buffer?      */
 164 #endif
 165
 166 String bool2str ( Bool b )
 167 {
 168    if (b) return "Yes"; else return "No ";
 169 }
 170
 171 void ppSmStack ( String who )
 172 {
 173    int i, j;
 174 return;
 175    fflush(stdout);fflush(stderr);
 176    printf ( "\n" );
 177    printf ( "ppSmStack %s:  numScripts = %d   namesUpto = %d  needsImports = %s\n",
 178             who, numScripts, namesUpto, bool2str(needsImports) );
 179    assert (namesUpto >= numScripts);
 180    printf ( "     Det FrS Pst ObL           Module Ext   Size ModTime  Path\n" );
 181    for (i = namesUpto-1; i >= 0; i--) {
 182       printf ( "%c%2d: %3s %3s %3s %3s %16s %-4s %5ld %8lx %s\n",
 183                (i==numScripts ? '*' : ' '),
 184                i, bool2str(scriptInfo[i].details),
 185                   bool2str(scriptInfo[i].fromSource),
 186                   bool2str(scriptInfo[i].postponed),
 187                   bool2str(scriptInfo[i].objLoaded),
 188                   scriptInfo[i].modName,
 189                   scriptInfo[i].fromSource ? scriptInfo[i].srcExt : "",
 190                   scriptInfo[i].size,
 191                   scriptInfo[i].lastChange,
 192                   scriptInfo[i].path
 193              );
 194    }
 195    fflush(stdout);fflush(stderr);
 196    ppScripts();
 197    ppModules();
 198    printf ( "\n" );
 199 }
 200
 201 /* --------------------------------------------------------------------------
 202  * Hugs entry point:
 203  * ------------------------------------------------------------------------*/
 204
 205 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
 206
 207 Main main ( Int, String [] );       /* now every func has a prototype  */
 208
 209 Main main(argc,argv)
 210 int  argc;
 211 char *argv[]; {
 212 #ifdef HAVE_CONSOLE_H /* Macintosh port */
 213     _ftype = 'TEXT';
 214     _fcreator = 'R*ch';       /*  // 'KAHL';      //'*TEX';       //'ttxt'; */
 215
 216     console_options.top = 50;
 217     console_options.left = 20;
 218
 219     console_options.nrows = 32;
 220     console_options.ncols = 80;
 221
 222     console_options.pause_atexit = 1;
 223     console_options.title = "\pHugs";
 224
 225     console_options.procID = 5;
 226     argc = ccommand(&argv);
 227 #endif
 228
 229     CStackBase = &argc;                 /* Save stack base for use in gc   */
 230
 231     /* If first arg is +Q or -Q, be entirely silent, and automatically run
 232        main after loading scripts.  Useful for running the nofib suite.    */
 233     if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
 234        autoMain = TRUE;
 235        if (strcmp(argv[1],"-Q") == 0) {
 236          hugsEnableOutput(0);
 237        }
 238     }
 239
 240     Printf("__   __ __  __  ____   ___      _________________________________________\n");
 241     Printf("||   || ||  || ||  || ||__      STGHugs: Based on the Haskell 98 standard\n");
 242     Printf("||___|| ||__|| ||__||  __||     Copyright (c) 1994-1999\n");
 243     Printf("||---||         ___||           World Wide Web: http://haskell.org/hugs\n");
 244     Printf("||   ||                         Report bugs to: hugs-bugs@haskell.org\n");
 245     Printf("||   || Version: %s _________________________________________\n\n",HUGS_VERSION);
 246
 247     /* Get the absolute path to the directory containing the hugs
 248        executable, so that we know where the Prelude and nHandle.so/.dll are.
 249        We do this by reading env var STGHUGSDIR.  This needs to succeed, so
 250        setInstallDir won't return unless it succeeds.
 251     */
 252     setInstallDir ( argv[0] );
 253
 254 #if SYMANTEC_C
 255     Printf("   Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
 256 #endif
 257     FlushStdout();
 258     interpreter(argc,argv);
 259     Printf("[Leaving Hugs]\n");
 260     everybody(EXIT);
 261     shutdownHaskell();
 262     FlushStdout();
 263     fflush(stderr);
 264     exit(0);
 265     MainDone();
 266 }
 267
 268 #endif
 269
 270 /* --------------------------------------------------------------------------
 271  * Initialization, interpret command line args and read prelude:
 272  * ------------------------------------------------------------------------*/
 273
 274 static Void local initialize(argc,argv)/* Interpreter initialization       */
 275 Int    argc;
 276 String argv[]; {
 277     Script i;
 278     String proj        = 0;
 279     char argv_0_orig[1000];
 280
 281     setLastEdit((String)0,0);
 282     lastEdit      = 0;
 283     scriptFile    = 0;
 284     numScripts    = 0;
 285     namesUpto     = 1;
 286
 287 #if HUGS_FOR_WINDOWS
 288     hugsEdit      = strCopy(fromEnv("EDITOR","c:\\windows\\notepad.exe"));
 289 #elif SYMANTEC_C
 290     hugsEdit      = "";
 291 #else
 292     hugsEdit      = strCopy(fromEnv("EDITOR",NULL));
 293 #endif
 294     hugsPath      = strCopy(HUGSPATH);
 295     readOptions("-p\"%s> \" -r$$");
 296 #if USE_REGISTRY
 297     projectPath   = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
 298                                                 "HUGSPATH", PATHSEP, ""));
 299     readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
 300     readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
 301 #endif /* USE_REGISTRY */
 302     readOptions(fromEnv("STGHUGSFLAGS",""));
 303
 304    strncpy(argv_0_orig,argv[0],1000);   /* startupHaskell mangles argv[0] */
 305    startupHaskell (argc,argv);
 306    argc = prog_argc; argv = prog_argv;
 307
 308    namesUpto = numScripts = 0;
 309
 310    /* Pre-scan flags to see if -c or +c is present.  This needs to
 311       precede adding the stack entry for Prelude.  On the other hand,
 312       that stack entry needs to be made before the cmd line args are
 313       properly examined.  Hence the following pre-scan of them.
 314    */
 315    for (i=1; i < argc; ++i) {
 316       if (strcmp(argv[i], "--")==0) break;
 317       if (strcmp(argv[i], "-c")==0) combined = FALSE;
 318       if (strcmp(argv[i], "+c")==0) combined = TRUE;
 319    }
 320
 321    addStackEntry("Prelude");
 322    if (combined) addStackEntry("PrelHugs");
 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 ( 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     {'S', 1, "Debug: show generated SC code",         &debugSC},
 792     {'a', 1, "Raise exception on assert failure",     &flagAssert},
 793 #if EXPLAIN_INSTANCE_RESOLUTION
 794     {'x', 1, "Explain instance resolution",           &showInstRes},
 795 #endif
 796 #if MULTI_INST
 797     {'m', 0, "Use multi instance resolution",         &multiInstRes},
 798 #endif
 799     {0,   0, 0,                                       0}
 800 };
 801
 802 static Void local set() {               /* change command line options from*/
 803     String s;                           /* Hugs command line               */
 804
 805     if ((s=readFilename())!=0) {
 806         do {
 807             if (!processOption(s)) {
 808                 ERRMSG(0) "Option string must begin with `+' or `-'"
 809                 EEND;
 810             }
 811         } while ((s=readFilename())!=0);
 812 #if USE_REGISTRY
 813         writeRegString("Options", optionsToStr());
 814 #endif
 815     }
 816     else
 817         optionInfo();
 818 }
 819
 820 /* --------------------------------------------------------------------------
 821  * Change directory command:
 822  * ------------------------------------------------------------------------*/
 823
 824 static Void local changeDir() {         /* change directory                */
 825     String s = readFilename();
 826     if (s && chdir(s)) {
 827         ERRMSG(0) "Unable to change to directory \"%s\"", s
 828         EEND;
 829     }
 830 }
 831
 832 /* --------------------------------------------------------------------------
 833  * Loading project and script files:
 834  * ------------------------------------------------------------------------*/
 835
 836 static Void local loadProject(s)        /* Load project file               */
 837 String s; {
 838     clearProject();
 839     currProject = s;
 840     projInput(currProject);
 841     scriptFile = currProject;
 842     forgetScriptsFrom(N_PRELUDE_SCRIPTS);
 843     while ((s=readFilename())!=0)
 844         addStackEntry(s);
 845     if (namesUpto<=1) {
 846         ERRMSG(0) "Empty project file"
 847         EEND;
 848     }
 849     scriptFile    = 0;
 850     projectLoaded = TRUE;
 851 }
 852
 853 static Void local clearProject() {      /* clear name for current project  */
 854     if (currProject)
 855         free(currProject);
 856     currProject   = 0;
 857     projectLoaded = FALSE;
 858 #if HUGS_FOR_WINDOWS
 859     setLastEdit((String)0,0);
 860 #endif
 861 }
 862
 863
 864
 865 static Void local makeStackEntry ( ScriptInfo* ent, String iname )
 866 {
 867    Bool   ok, fromObj;
 868    Bool   sAvail, iAvail, oAvail;
 869    Time   sTime,  iTime,  oTime;
 870    Long   sSize,  iSize,  oSize;
 871    String path,   sExt;
 872
 873    ok = findFilesForModule (
 874            iname,
 875            &path,
 876            &sExt,
 877            &sAvail, &sTime, &sSize,
 878            &iAvail, &iTime, &iSize,
 879            &oAvail, &oTime, &oSize
 880         );
 881    if (!ok) {
 882       ERRMSG(0)
 883          "Can't find source or object+interface for module \"%s\"",
 884          /* "Can't find source for module \"%s\"", */
 885          iname
 886       EEND;
 887    }
 888    /* findFilesForModule should enforce this */
 889    if (!(sAvail || (oAvail && iAvail)))
 890       internal("chase");
 891    /* Load objects in preference to sources if both are available */
 892    /* 11 Oct 99: disable object loading in the interim.
 893       Will probably only reinstate when HEP becomes available.
 894    */
 895    if (combined) {
 896       fromObj = sAvail
 897                 ? (oAvail && iAvail && timeEarlier(sTime,oTime))
 898                 : TRUE;
 899    } else {
 900       fromObj = FALSE;
 901    }
 902
 903    /* ToDo: namesUpto overflow */
 904    ent->modName     = strCopy(iname);
 905    ent->details     = TRUE;
 906    ent->path        = path;
 907    ent->fromSource  = !fromObj;
 908    ent->srcExt      = sExt;
 909    ent->postponed   = FALSE;
 910    ent->lastChange  = sTime; /* ToDo: is this right? */
 911    ent->size        = fromObj ? iSize : sSize;
 912    ent->oSize       = fromObj ? oSize : 0;
 913    ent->objLoaded   = FALSE;
 914 }
 915
 916
 917
 918 static Void nukeEnding( String s )
 919 {
 920     Int l = strlen(s);
 921     if (l > 4 && strncmp(s+l-4,".u_o" ,4)==0) s[l-4] = 0; else
 922     if (l > 5 && strncmp(s+l-5,".u_hi",5)==0) s[l-5] = 0; else
 923     if (l > 3 && strncmp(s+l-3,".hs"  ,3)==0) s[l-3] = 0; else
 924     if (l > 4 && strncmp(s+l-4,".lhs" ,4)==0) s[l-4] = 0; else
 925     if (l > 4 && strncmp(s+l-4,".dll" ,4)==0) s[l-4] = 0; else
 926     if (l > 4 && strncmp(s+l-4,".DLL" ,4)==0) s[l-4] = 0;
 927 }
 928
 929 static Void local addStackEntry(s)     /* Add script to list of scripts    */
 930 String s; {                            /* to be read in ...                */
 931     String s2;
 932     Bool   found;
 933     Int    i;
 934
 935     if (namesUpto>=NUM_SCRIPTS) {
 936         ERRMSG(0) "Too many module files (maximum of %d allowed)",
 937                   NUM_SCRIPTS
 938         EEND;
 939     }
 940
 941     s = strCopy(s);
 942     nukeEnding(s);
 943     for (s2 = s; *s2; s2++)
 944        if (*s2 == SLASH && *(s2+1)) s = s2+1;
 945
 946     found = FALSE;
 947     for (i = 0; i < namesUpto; i++)
 948        if (strcmp(scriptInfo[i].modName,s)==0)
 949           found = TRUE;
 950
 951     if (!found) {
 952        makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) );
 953        namesUpto++;
 954     }
 955     free(s);
 956 }
 957
 958 /* Return TRUE if no imports were needed; FALSE otherwise. */
 959 static Bool local addScript(stacknum)   /* read single file                */
 960 Int stacknum; {
 961    Bool didPrelude;
 962    static char name[FILENAME_MAX+1];
 963    Int len = scriptInfo[stacknum].size;
 964
 965 #if HUGS_FOR_WINDOWS                    /* Set clock cursor while loading  */
 966     allowBreak();
 967     SetCursor(LoadCursor(NULL, IDC_WAIT));
 968 #endif
 969
 970     //   setLastEdit(name,0);
 971
 972    strcpy(name, scriptInfo[stacknum].path);
 973    strcat(name, scriptInfo[stacknum].modName);
 974    if (scriptInfo[stacknum].fromSource)
 975       strcat(name, scriptInfo[stacknum].srcExt); else
 976       strcat(name, ".u_hi");
 977
 978    scriptFile = name;
 979
 980    if (scriptInfo[stacknum].fromSource) {
 981       if (lastWasObject) {
 982          didPrelude = processInterfaces();
 983          if (didPrelude) {
 984             preludeLoaded = TRUE;
 985             everybody(POSTPREL);
 986          }
 987       }
 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    return TRUE;
1029 }
1030
1031
1032 Bool chase(imps)                        /* Process list of import requests */
1033 List imps; {
1034     Int    dstPosn;
1035     ScriptInfo tmp;
1036     Int    origPos  = numScripts;       /* keep track of original position */
1037     String origName = scriptInfo[origPos].modName;
1038     for (; nonNull(imps); imps=tl(imps)) {
1039         String iname = textToStr(textOf(hd(imps)));
1040         Int    i     = 0;
1041         for (; i<namesUpto; i++)
1042             if (strcmp(scriptInfo[i].modName,iname)==0)
1043                 break;
1044         //fprintf(stderr, "import name = %s   num = %d\n", iname, i );
1045
1046         if (i<namesUpto) {
1047            /* We should have filled in the details of each module
1048               the first time we hear about it.
1049            */
1050            assert(scriptInfo[i].details);
1051         }
1052
1053         if (i>=origPos) {               /* Neither loaded or queued        */
1054             String theName;
1055             Time   theTime;
1056             Bool   thePost;
1057             Bool   theFS;
1058
1059             needsImports = TRUE;
1060             if (scriptInfo[origPos].fromSource)
1061                scriptInfo[origPos].postponed  = TRUE;
1062
1063             if (i==namesUpto) {         /* Name not found (i==namesUpto)   */
1064                  /* Find out where it lives, whether source or object, etc */
1065                makeStackEntry ( &scriptInfo[i], iname );
1066                namesUpto++;
1067             }
1068             else
1069             if (scriptInfo[i].postponed && scriptInfo[i].fromSource) {
1070                                         /* Check for recursive dependency  */
1071                 ERRMSG(0)
1072                   "Recursive import dependency between \"%s\" and \"%s\"",
1073                   scriptInfo[origPos].modName, iname
1074                 EEND;
1075             }
1076             /* Move stack entry i to somewhere below origPos.  If i denotes
1077              * an object, destination is immediately below origPos.
1078              * Otherwise, it's underneath the queue of objects below origPos.
1079              */
1080             dstPosn = origPos-1;
1081             if (scriptInfo[i].fromSource)
1082                while (!scriptInfo[dstPosn].fromSource && dstPosn > 0)
1083                   dstPosn--;
1084
1085             dstPosn++;
1086             tmp = scriptInfo[i];
1087             for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1];
1088             scriptInfo[dstPosn] = tmp;
1089             if (dstPosn < nextNumScripts) nextNumScripts = dstPosn;
1090             origPos++;
1091         }
1092     }
1093     return needsImports;
1094 }
1095
1096 static Void local forgetScriptsFrom(scno)/* remove scripts from system     */
1097 Script scno; {
1098     Script i;
1099 #if 0
1100     for (i=scno; i<namesUpto; ++i)
1101         if (scriptName[i])
1102             free(scriptName[i]);
1103 #endif
1104     dropScriptsFrom(scno-1);
1105     namesUpto = scno;
1106     if (numScripts>namesUpto)
1107         numScripts = scno;
1108 }
1109
1110 /* --------------------------------------------------------------------------
1111  * Commands for loading and removing script files:
1112  * ------------------------------------------------------------------------*/
1113
1114 static Void local load() {           /* read filenames from command line   */
1115     String s;                        /* and add to list of scripts waiting */
1116                                      /* to be read                         */
1117     while ((s=readFilename())!=0)
1118         addStackEntry(s);
1119     readScripts(N_PRELUDE_SCRIPTS);
1120 }
1121
1122 static Void local project() {          /* read list of script names from   */
1123     String s;                          /* project file                     */
1124
1125     if ((s=readFilename()) || currProject) {
1126         if (!s)
1127             s = strCopy(currProject);
1128         else if (readFilename()) {
1129             ERRMSG(0) "Too many project files"
1130             EEND;
1131         }
1132         else
1133             s = strCopy(s);
1134     }
1135     else {
1136         ERRMSG(0) "No project filename specified"
1137         EEND;
1138     }
1139     loadProject(s);
1140     readScripts(N_PRELUDE_SCRIPTS);
1141 }
1142
1143 static Void local readScripts(n)        /* Reread current list of scripts, */
1144 Int n; {                                /* loading everything after and    */
1145     Time timeStamp;                     /* including the first script which*/
1146     Long fileSize;                      /* has been either changed or added*/
1147     static char name[FILENAME_MAX+1];
1148     Bool didPrelude;
1149
1150     lastWasObject = FALSE;
1151     ppSmStack("readscripts-begin");
1152 #if HUGS_FOR_WINDOWS
1153     SetCursor(LoadCursor(NULL, IDC_WAIT));
1154 #endif
1155
1156 #if 0
1157     for (; n<numScripts; n++) {         /* Scan previously loaded scripts  */
1158         ppSmStack("readscripts-loop1");
1159         getFileInfo(scriptName[n], &timeStamp, &fileSize);
1160         if (timeChanged(timeStamp,lastChange[n])) {
1161             dropScriptsFrom(n-1);
1162             numScripts = n;
1163             break;
1164         }
1165     }
1166     for (; n<NUM_SCRIPTS; n++)          /* No scripts have been postponed  */
1167         postponed[n] = FALSE;           /* at this stage                   */
1168     numScripts = 0;
1169
1170     while (numScripts<namesUpto) {      /* Process any remaining scripts   */
1171         ppSmStack("readscripts-loop2");
1172         getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
1173         timeSet(lastChange[numScripts],timeStamp);
1174         if (numScripts>0)               /* no new script for prelude       */
1175             startNewScript(scriptName[numScripts]);
1176         if (addScript(scriptName[numScripts],fileSize))
1177             numScripts++;
1178         else
1179             dropScriptsFrom(numScripts-1);
1180     }
1181 #endif
1182
1183     interface(RESET);
1184
1185     for (; n<numScripts; n++) {
1186         ppSmStack("readscripts-loop2");
1187         strcpy(name, scriptInfo[n].path);
1188         strcat(name, scriptInfo[n].modName);
1189         if (scriptInfo[n].fromSource)
1190            strcat(name, scriptInfo[n].srcExt); else
1191            strcat(name, ".u_hi");  //ToDo: should be .o
1192         getFileInfo(name,&timeStamp, &fileSize);
1193         if (timeChanged(timeStamp,scriptInfo[n].lastChange)) {
1194            dropScriptsFrom(n-1);
1195            numScripts = n;
1196            break;
1197         }
1198     }
1199     for (; n<NUM_SCRIPTS; n++)
1200         scriptInfo[n].postponed = FALSE;
1201
1202     //numScripts = 0;
1203
1204     while (numScripts < namesUpto) {
1205        ppSmStack ( "readscripts-loop2" );
1206
1207        if (scriptInfo[numScripts].fromSource) {
1208
1209           if (numScripts>0)
1210               startNewScript(scriptInfo[numScripts].modName);
1211           nextNumScripts = NUM_SCRIPTS; //bogus initialisation
1212           if (addScript(numScripts)) {
1213              numScripts++;
1214              assert(nextNumScripts==NUM_SCRIPTS);
1215           }
1216           else
1217              dropScriptsFrom(numScripts-1);
1218
1219        } else {
1220
1221           if (scriptInfo[numScripts].objLoaded) {
1222              numScripts++;
1223           } else {
1224              scriptInfo[numScripts].objLoaded = TRUE;
1225              /* new */
1226              if (numScripts>0)
1227                  startNewScript(scriptInfo[numScripts].modName);
1228              /* end */
1229              nextNumScripts = NUM_SCRIPTS;
1230              if (addScript(numScripts)) {
1231                 numScripts++;
1232                 assert(nextNumScripts==NUM_SCRIPTS);
1233              } else {
1234                 //while (!scriptInfo[numScripts].fromSource && numScripts > 0)
1235                 //   numScripts--;
1236                 //if (scriptInfo[numScripts].fromSource)
1237                 //   numScripts++;
1238                 numScripts = nextNumScripts;
1239                 assert(nextNumScripts<NUM_SCRIPTS);
1240              }
1241           }
1242        }
1243        if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
1244     }
1245
1246     didPrelude = processInterfaces();
1247     if (didPrelude) {
1248        preludeLoaded = TRUE;
1249        everybody(POSTPREL);
1250     }
1251
1252
1253     { Int  m     = namesUpto-1;
1254       Text mtext = findText(scriptInfo[m].modName);
1255
1256       /* Hack to avoid starting up in PrelHugs */
1257       if (mtext == findText("PrelHugs")) mtext = findText("Prelude");
1258
1259
1260       /* Commented out till we understand what
1261        * this is trying to do.
1262        * Problem, you cant find a module till later.
1263        */
1264 #if 0
1265        setCurrModule(findModule(mtext));
1266 #endif
1267       evalModule = mtext;
1268     }
1269
1270
1271
1272     if (listScripts)
1273         whatScripts();
1274     if (numScripts<=1)
1275         setLastEdit((String)0, 0);
1276     ppSmStack("readscripts-end  ");
1277 }
1278
1279 static Void local whatScripts() {       /* list scripts in current session */
1280     int i;
1281     Printf("\nHugs session for:");
1282     if (projectLoaded)
1283         Printf(" (project: %s)",currProject);
1284     for (i=0; i<numScripts; ++i)
1285       Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
1286     Putchar('\n');
1287 }
1288
1289 /* --------------------------------------------------------------------------
1290  * Access to external editor:
1291  * ------------------------------------------------------------------------*/
1292
1293 static Void local editor() {            /* interpreter-editor interface    */
1294     String newFile  = readFilename();
1295     if (newFile) {
1296         setLastEdit(newFile,0);
1297         if (readFilename()) {
1298             ERRMSG(0) "Multiple filenames not permitted"
1299             EEND;
1300         }
1301     }
1302     runEditor();
1303 }
1304
1305 static Void local find() {              /* edit file containing definition */
1306 #if 0
1307 This just plain wont work no more.
1308 ToDo: Fix!
1309     String nm = readFilename();         /* of specified name               */
1310     if (!nm) {
1311         ERRMSG(0) "No name specified"
1312         EEND;
1313     }
1314     else if (readFilename()) {
1315         ERRMSG(0) "Multiple names not permitted"
1316         EEND;
1317     }
1318     else {
1319         Text t;
1320         Cell c;
1321         setCurrModule(findEvalModule());
1322         startNewScript(0);
1323         if (nonNull(c=findTycon(t=findText(nm)))) {
1324             if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1325                 readScripts(N_PRELUDE_SCRIPTS);
1326             }
1327         } else if (nonNull(c=findName(t))) {
1328             if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1329                 readScripts(N_PRELUDE_SCRIPTS);
1330             }
1331         } else {
1332             ERRMSG(0) "No current definition for name \"%s\"", nm
1333             EEND;
1334         }
1335     }
1336 #endif
1337 }
1338
1339 static Void local runEditor() {         /* run editor on script lastEdit   */
1340     if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine              */
1341         readScripts(N_PRELUDE_SCRIPTS);
1342 }
1343
1344 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1345 String fname;
1346 Int    line; {
1347     if (lastEdit)
1348         free(lastEdit);
1349     lastEdit = strCopy(fname);
1350     lastEdLine = line;
1351 #if HUGS_FOR_WINDOWS
1352     DrawStatusLine(hWndMain);           /* Redo status line                */
1353 #endif
1354 }
1355
1356 /* --------------------------------------------------------------------------
1357  * Read and evaluate an expression:
1358  * ------------------------------------------------------------------------*/
1359
1360 static Void local setModule(){/*set module in which to evaluate expressions*/
1361     String s = readFilename();
1362     if (!s) s = "";              /* :m clears the current module selection */
1363     evalModule = findText(s);
1364     setLastEdit(fileOfModule(findEvalModule()),0);
1365 }
1366
1367 static Module local findEvalModule() { /*Module in which to eval expressions*/
1368     Module m = findModule(evalModule);
1369     if (isNull(m))
1370         m = lastModule();
1371     return m;
1372 }
1373
1374 static Void local evaluator() {        /* evaluate expr and print value    */
1375     Type  type, bd;
1376     Kinds ks   = NIL;
1377
1378     setCurrModule(findEvalModule());
1379     scriptFile = 0;
1380     startNewScript(0);                 /* Enables recovery of storage      */
1381                                        /* allocated during evaluation      */
1382     parseExp();
1383     checkExp();
1384     defaultDefns = combined ? stdDefaults : evalDefaults;
1385     type         = typeCheckExp(TRUE);
1386
1387     if (isPolyType(type)) {
1388         ks = polySigOf(type);
1389         bd = monotypeOf(type);
1390     }
1391     else
1392         bd = type;
1393
1394     if (whatIs(bd)==QUAL) {
1395         ERRMSG(0) "Unresolved overloading" ETHEN
1396         ERRTEXT   "\n*** Type       : "    ETHEN ERRTYPE(type);
1397         ERRTEXT   "\n*** Expression : "    ETHEN ERREXPR(inputExpr);
1398         ERRTEXT   "\n"
1399         EEND;
1400     }
1401
1402 #ifdef WANT_TIMER
1403     updateTimers();
1404 #endif
1405
1406 #if 1
1407     if (isProgType(ks,bd)) {
1408         inputExpr = ap(nameRunIO_toplevel,inputExpr);
1409         evalExp();
1410         Putchar('\n');
1411     } else {
1412         Cell d = provePred(ks,NIL,ap(classShow,bd));
1413         if (isNull(d)) {
1414             ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1415             ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
1416             ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
1417             ERRTEXT   "\n"
1418             EEND;
1419         }
1420         inputExpr = ap2(nameShow,           d,inputExpr);
1421         inputExpr = ap (namePutStr,         inputExpr);
1422         inputExpr = ap (nameRunIO_toplevel, inputExpr);
1423
1424         evalExp(); printf("\n");
1425         if (addType) {
1426             printf(" :: ");
1427             printType(stdout,type);
1428             Putchar('\n');
1429         }
1430     }
1431
1432 #else
1433
1434    printf ( "result type is " );
1435    printType ( stdout, type );
1436    printf ( "\n" );
1437    evalExp();
1438    printf ( "\n" );
1439
1440 #endif
1441
1442 }
1443
1444 static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
1445     if (printing) {                    /* after successful termination or  */
1446         printing = FALSE;              /* runtime error (e.g. interrupt)   */
1447         Putchar('\n');
1448         if (showStats) {
1449 #define plural(v)   v, (v==1?"":"s")
1450             Printf("%lu cell%s",plural(numCells));
1451             if (numGcs>0)
1452                 Printf(", %u garbage collection%s",plural(numGcs));
1453             Printf(")\n");
1454 #undef plural
1455         }
1456         FlushStdout();
1457         garbageCollect();
1458     }
1459 }
1460
1461 /* --------------------------------------------------------------------------
1462  * Print type of input expression:
1463  * ------------------------------------------------------------------------*/
1464
1465 static Void local showtype() {         /* print type of expression (if any)*/
1466     Cell type;
1467
1468     setCurrModule(findEvalModule());
1469     startNewScript(0);                 /* Enables recovery of storage      */
1470                                        /* allocated during evaluation      */
1471     parseExp();
1472     checkExp();
1473     defaultDefns = evalDefaults;
1474     type = typeCheckExp(FALSE);
1475     printExp(stdout,inputExpr);
1476     Printf(" :: ");
1477     printType(stdout,type);
1478     Putchar('\n');
1479 }
1480
1481
1482 static Void local browseit(mod,t,all)
1483 Module mod;
1484 String t;
1485 Bool all; {
1486     if (nonNull(mod)) {
1487         Cell cs;
1488         if (nonNull(t))
1489             Printf("module %s where\n",textToStr(module(mod).text));
1490         for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1491             Name nm = hd(cs);
1492             /* only look at things defined in this module,
1493                unless `all' flag is set */
1494             if (all || name(nm).mod == mod) {
1495                 /* unwanted artifacts, like lambda lifted values,
1496                    are in the list of names, but have no types */
1497                 if (nonNull(name(nm).type)) {
1498                     printExp(stdout,nm);
1499                     Printf(" :: ");
1500                     printType(stdout,name(nm).type);
1501                     if (isCfun(nm)) {
1502                         Printf("  -- data constructor");
1503                     } else if (isMfun(nm)) {
1504                         Printf("  -- class member");
1505                     } else if (isSfun(nm)) {
1506                         Printf("  -- selector function");
1507                     }
1508                     Printf("\n");
1509                 }
1510             }
1511         }
1512     } else {
1513       if (isNull(mod)) {
1514         Printf("Unknown module %s\n",t);
1515       }
1516     }
1517 }
1518
1519 static Void local browse() {            /* browse modules                  */
1520     Int    count = 0;                   /* or give menu of commands        */
1521     String s;
1522     Bool all = FALSE;
1523
1524     setCurrModule(findEvalModule());
1525     startNewScript(0);                  /* for recovery of storage         */
1526     for (; (s=readFilename())!=0; count++)
1527         if (strcmp(s,"all") == 0) {
1528             all = TRUE;
1529             --count;
1530         } else
1531             browseit(findModule(findText(s)),s,all);
1532     if (count == 0) {
1533         browseit(findEvalModule(),NULL,all);
1534     }
1535 }
1536
1537 #if EXPLAIN_INSTANCE_RESOLUTION
1538 static Void local xplain() {         /* print type of expression (if any)*/
1539     Cell d;
1540     Bool sir = showInstRes;
1541
1542     setCurrModule(findEvalModule());
1543     startNewScript(0);                 /* Enables recovery of storage      */
1544                                        /* allocated during evaluation      */
1545     parseContext();
1546     checkContext();
1547     showInstRes = TRUE;
1548     d = provePred(NIL,NIL,hd(inputContext));
1549     if (isNull(d)) {
1550         fprintf(stdout, "not Sat\n");
1551     } else {
1552         fprintf(stdout, "Sat\n");
1553     }
1554     showInstRes = sir;
1555 }
1556 #endif
1557
1558 /* --------------------------------------------------------------------------
1559  * Enhanced help system:  print current list of scripts or give information
1560  * about an object.
1561  * ------------------------------------------------------------------------*/
1562
1563 static String local objToStr(m,c)
1564 Module m;
1565 Cell   c; {
1566 #if 1 || DISPLAY_QUANTIFIERS
1567     static char newVar[60];
1568     switch (whatIs(c)) {
1569         case NAME  : if (m == name(c).mod) {
1570                          sprintf(newVar,"%s", textToStr(name(c).text));
1571                      } else {
1572                          sprintf(newVar,"%s.%s",
1573                                         textToStr(module(name(c).mod).text),
1574                                         textToStr(name(c).text));
1575                      }
1576                      break;
1577
1578         case TYCON : if (m == tycon(c).mod) {
1579                          sprintf(newVar,"%s", textToStr(tycon(c).text));
1580                      } else {
1581                          sprintf(newVar,"%s.%s",
1582                                         textToStr(module(tycon(c).mod).text),
1583                                         textToStr(tycon(c).text));
1584                      }
1585                      break;
1586
1587         case CLASS : if (m == cclass(c).mod) {
1588                          sprintf(newVar,"%s", textToStr(cclass(c).text));
1589                      } else {
1590                          sprintf(newVar,"%s.%s",
1591                                         textToStr(module(cclass(c).mod).text),
1592                                         textToStr(cclass(c).text));
1593                      }
1594                      break;
1595
1596         default    : internal("objToStr");
1597     }
1598     return newVar;
1599 #else
1600     static char newVar[33];
1601     switch (whatIs(c)) {
1602         case NAME  : sprintf(newVar,"%s", textToStr(name(c).text));
1603                      break;
1604
1605         case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1606                      break;
1607
1608         case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1609                      break;
1610
1611         default    : internal("objToStr");
1612     }
1613     return newVar;
1614 #endif
1615 }
1616
1617 extern Name nameHw;
1618
1619 static Void dumpStg ( void )
1620 {
1621    String s;
1622    Int i;
1623    setCurrModule(findEvalModule());
1624    startNewScript(0);
1625    s = readFilename();
1626
1627    /* request to locate a symbol by name */
1628    if (s && (*s == '?')) {
1629       Text t = findText(s+1);
1630       locateSymbolByName(t);
1631       return;
1632    }
1633
1634    /* request to dump a bit of the heap */
1635    if (s && (*s == '-' || isdigit(*s))) {
1636       int i = atoi(s);
1637       print(i,100);
1638       printf("\n");
1639       return;
1640    }
1641
1642    /* request to dump a symbol table entry */
1643    if (!s
1644        || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
1645        || !isdigit(s[1])) {
1646       fprintf(stderr, ":d -- bad request `%s'\n", s );
1647       return;
1648    }
1649    i = atoi(s+1);
1650    switch (*s) {
1651       case 't': dumpTycon(i); break;
1652       case 'n': dumpName(i); break;
1653       case 'c': dumpClass(i); break;
1654       case 'i': dumpInst(i); break;
1655       default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
1656    }
1657 }
1658
1659
1660 #if 0
1661 static Void local dumpStg( void ) {       /* print STG stuff                 */
1662     String s;
1663     Text   t;
1664     Name   n;
1665     Int    i;
1666     Cell   v;                           /* really StgVar */
1667     setCurrModule(findEvalModule());
1668     startNewScript(0);
1669     for (; (s=readFilename())!=0;) {
1670         t = findText(s);
1671         v = n = NIL;
1672         /* find the name while ignoring module scopes */
1673         for (i=NAMEMIN; i<nameHw; i++)
1674            if (name(i).text == t) n = i;
1675
1676         /* perhaps it's an "idNNNNNN" thing? */
1677         if (isNull(n) &&
1678             strlen(s) >= 3 &&
1679             s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1680            v = 0;
1681            i = 2;
1682            while (isdigit(s[i])) {
1683               v = v * 10 + (s[i]-'0');
1684               i++;
1685            }
1686            v = -v;
1687            n = nameFromStgVar(v);
1688         }
1689
1690         if (isNull(n) && whatIs(v)==STGVAR) {
1691            Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1692            printStg(stderr, v );
1693         } else
1694         if (isNull(n)) {
1695            Printf ( "Unknown reference `%s'\n", s );
1696         } else
1697         if (!isName(n)) {
1698            Printf ( "Not a Name: `%s'\n", s );
1699         } else
1700         if (isNull(name(n).stgVar)) {
1701            Printf ( "Doesn't have a STG tree: %s\n", s );
1702         } else {
1703            Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1704            printStg(stderr, name(n).stgVar);
1705         }
1706     }
1707 }
1708 #endif
1709
1710 static Void local info() {              /* describe objects                */
1711     Int    count = 0;                   /* or give menu of commands        */
1712     String s;
1713
1714     setCurrModule(findEvalModule());
1715     startNewScript(0);                  /* for recovery of storage         */
1716     for (; (s=readFilename())!=0; count++) {
1717         describe(findText(s));
1718     }
1719     if (count == 0) {
1720         whatScripts();
1721     }
1722 }
1723
1724
1725 static Void local describe(t)           /* describe an object              */
1726 Text t; {
1727     Tycon  tc  = findTycon(t);
1728     Class  cl  = findClass(t);
1729     Name   nm  = findName(t);
1730
1731     if (nonNull(tc)) {                  /* as a type constructor           */
1732         Type t = tc;
1733         Int  i;
1734         Inst in;
1735         for (i=0; i<tycon(tc).arity; ++i) {
1736             t = ap(t,mkOffset(i));
1737         }
1738         Printf("-- type constructor");
1739         if (kindExpert) {
1740             Printf(" with kind ");
1741             printKind(stdout,tycon(tc).kind);
1742         }
1743         Putchar('\n');
1744         switch (tycon(tc).what) {
1745             case SYNONYM      : Printf("type ");
1746                                 printType(stdout,t);
1747                                 Printf(" = ");
1748                                 printType(stdout,tycon(tc).defn);
1749                                 break;
1750
1751             case NEWTYPE      :
1752             case DATATYPE     : {   List cs = tycon(tc).defn;
1753                                     if (tycon(tc).what==DATATYPE) {
1754                                         Printf("data ");
1755                                     } else {
1756                                         Printf("newtype ");
1757                                     }
1758                                     printType(stdout,t);
1759                                     Putchar('\n');
1760                                     mapProc(printSyntax,cs);
1761                                     if (hasCfun(cs)) {
1762                                         Printf("\n-- constructors:");
1763                                     }
1764                                     for (; hasCfun(cs); cs=tl(cs)) {
1765                                         Putchar('\n');
1766                                         printExp(stdout,hd(cs));
1767                                         Printf(" :: ");
1768                                         printType(stdout,name(hd(cs)).type);
1769                                     }
1770                                     if (nonNull(cs)) {
1771                                         Printf("\n-- selectors:");
1772                                     }
1773                                     for (; nonNull(cs); cs=tl(cs)) {
1774                                         Putchar('\n');
1775                                         printExp(stdout,hd(cs));
1776                                         Printf(" :: ");
1777                                         printType(stdout,name(hd(cs)).type);
1778                                     }
1779                                 }
1780                                 break;
1781
1782             case RESTRICTSYN  : Printf("type ");
1783                                 printType(stdout,t);
1784                                 Printf(" = <restricted>");
1785                                 break;
1786         }
1787         Putchar('\n');
1788         if (nonNull(in=findFirstInst(tc))) {
1789             Printf("\n-- instances:\n");
1790             do {
1791                 showInst(in);
1792                 in = findNextInst(tc,in);
1793             } while (nonNull(in));
1794         }
1795         Putchar('\n');
1796     }
1797
1798     if (nonNull(cl)) {                  /* as a class                      */
1799         List  ins = cclass(cl).instances;
1800         Kinds ks  = cclass(cl).kinds;
1801         if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1802             Printf("-- type class");
1803         } else {
1804             Printf("-- constructor class");
1805             if (kindExpert) {
1806                 Printf(" with arity ");
1807                 printKinds(stdout,ks);
1808             }
1809         }
1810         Putchar('\n');
1811         mapProc(printSyntax,cclass(cl).members);
1812         Printf("class ");
1813         if (nonNull(cclass(cl).supers)) {
1814             printContext(stdout,cclass(cl).supers);
1815             Printf(" => ");
1816         }
1817         printPred(stdout,cclass(cl).head);
1818
1819         if (nonNull(cclass(cl).fds)) {
1820             List   fds = cclass(cl).fds;
1821             String pre = " | ";
1822             for (; nonNull(fds); fds=tl(fds)) {
1823                 Printf(pre);
1824                 printFD(stdout,hd(fds));
1825                 pre = ", ";
1826             }
1827         }
1828
1829         if (nonNull(cclass(cl).members)) {
1830             List ms = cclass(cl).members;
1831             Printf(" where");
1832             do {
1833                 Type t = name(hd(ms)).type;
1834                 if (isPolyType(t)) {
1835                     t = monotypeOf(t);
1836                 }
1837                 Printf("\n  ");
1838                 printExp(stdout,hd(ms));
1839                 Printf(" :: ");
1840                 if (isNull(tl(fst(snd(t))))) {
1841                     t = snd(snd(t));
1842                 } else {
1843                     t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1844                 }
1845                 printType(stdout,t);
1846                 ms = tl(ms);
1847             } while (nonNull(ms));
1848         }
1849         Putchar('\n');
1850         if (nonNull(ins)) {
1851             Printf("\n-- instances:\n");
1852             do {
1853                 showInst(hd(ins));
1854                 ins = tl(ins);
1855             } while (nonNull(ins));
1856         }
1857         Putchar('\n');
1858     }
1859
1860     if (nonNull(nm)) {                  /* as a function/name              */
1861         printSyntax(nm);
1862         printExp(stdout,nm);
1863         Printf(" :: ");
1864         if (nonNull(name(nm).type)) {
1865             printType(stdout,name(nm).type);
1866         } else {
1867             Printf("<unknown type>");
1868         }
1869         if (isCfun(nm)) {
1870             Printf("  -- data constructor");
1871         } else if (isMfun(nm)) {
1872             Printf("  -- class member");
1873         } else if (isSfun(nm)) {
1874             Printf("  -- selector function");
1875         }
1876         Printf("\n\n");
1877     }
1878
1879
1880     if (isNull(tc) && isNull(cl) && isNull(nm)) {
1881         Printf("Unknown reference `%s'\n",textToStr(t));
1882     }
1883 }
1884
1885 static Void local printSyntax(nm)
1886 Name nm; {
1887     Syntax sy = syntaxOf(nm);
1888     Text   t  = name(nm).text;
1889     String s  = textToStr(t);
1890     if (sy != defaultSyntax(t)) {
1891         Printf("infix");
1892         switch (assocOf(sy)) {
1893             case LEFT_ASS  : Putchar('l'); break;
1894             case RIGHT_ASS : Putchar('r'); break;
1895             case NON_ASS   : break;
1896         }
1897         Printf(" %i ",precOf(sy));
1898         if (isascii((int)(*s)) && isalpha((int)(*s))) {
1899             Printf("`%s`",s);
1900         } else {
1901             Printf("%s",s);
1902         }
1903         Putchar('\n');
1904     }
1905 }
1906
1907 static Void local showInst(in)          /* Display instance decl header    */
1908 Inst in; {
1909     Printf("instance ");
1910     if (nonNull(inst(in).specifics)) {
1911         printContext(stdout,inst(in).specifics);
1912         Printf(" => ");
1913     }
1914     printPred(stdout,inst(in).head);
1915     Putchar('\n');
1916 }
1917
1918 /* --------------------------------------------------------------------------
1919  * List all names currently in scope:
1920  * ------------------------------------------------------------------------*/
1921
1922 static Void local listNames() {         /* list names matching optional pat*/
1923     String pat   = readFilename();
1924     List   names = NIL;
1925     Int    width = getTerminalWidth() - 1;
1926     Int    count = 0;
1927     Int    termPos;
1928     Module mod   = findEvalModule();
1929
1930     if (pat) {                          /* First gather names to list      */
1931         do {
1932             names = addNamesMatching(pat,names);
1933         } while ((pat=readFilename())!=0);
1934     } else {
1935         names = addNamesMatching((String)0,names);
1936     }
1937     if (isNull(names)) {                /* Then print them out             */
1938         ERRMSG(0) "No names selected"
1939         EEND;
1940     }
1941     for (termPos=0; nonNull(names); names=tl(names)) {
1942         String s = objToStr(mod,hd(names));
1943         Int    l = strlen(s);
1944         if (termPos+1+l>width) {
1945             Putchar('\n');
1946             termPos = 0;
1947         } else if (termPos>0) {
1948             Putchar(' ');
1949             termPos++;
1950         }
1951         Printf("%s",s);
1952         termPos += l;
1953         count++;
1954     }
1955     Printf("\n(%d names listed)\n", count);
1956 }
1957
1958 /* --------------------------------------------------------------------------
1959  * print a prompt and read a line of input:
1960  * ------------------------------------------------------------------------*/
1961
1962 static Void local promptForInput(moduleName)
1963 String moduleName; {
1964     char promptBuffer[1000];
1965 #if 1
1966     /* This is portable but could overflow buffer */
1967     sprintf(promptBuffer,prompt,moduleName);
1968 #else
1969     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1970      * promptBuffer instead.
1971      */
1972     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1973         /* Reset prompt to a safe default to avoid an infinite loop */
1974         free(prompt);
1975         prompt = strCopy("? ");
1976         internal("Combined prompt and evaluation module name too long");
1977     }
1978 #endif
1979     if (autoMain)
1980        stringInput("main\0"); else
1981        consoleInput(promptBuffer);
1982 }
1983
1984 /* --------------------------------------------------------------------------
1985  * main read-eval-print loop, with error trapping:
1986  * ------------------------------------------------------------------------*/
1987
1988 static jmp_buf catch_error;             /* jump buffer for error trapping  */
1989
1990 static Void local interpreter(argc,argv)/* main interpreter loop           */
1991 Int    argc;
1992 String argv[]; {
1993     Int errorNumber = setjmp(catch_error);
1994
1995     if (errorNumber && autoMain) {
1996        fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
1997        exit(1);
1998     }
1999
2000     breakOn(TRUE);                      /* enable break trapping           */
2001     if (numScripts==0) {                /* only succeeds on first time,    */
2002         if (errorNumber)                /* before prelude has been loaded  */
2003             fatal("Unable to load prelude");
2004         initialize(argc,argv);
2005         forHelp();
2006     }
2007
2008     /* initialize calls startupHaskell, which trashes our signal handlers */
2009     breakOn(TRUE);
2010
2011     for (;;) {
2012         Command cmd;
2013         everybody(RESET);               /* reset to sensible initial state */
2014         dropScriptsFrom(numScripts-1);  /* remove partially loaded scripts */
2015                                         /* not counting prelude as a script*/
2016
2017         promptForInput(textToStr(module(findEvalModule()).text));
2018
2019         cmd = readCommand(cmds, (Char)':', (Char)'!');
2020 #ifdef WANT_TIMER
2021         updateTimers();
2022 #endif
2023         switch (cmd) {
2024             case EDIT   : editor();
2025                           break;
2026             case FIND   : find();
2027                           break;
2028             case LOAD   : clearProject();
2029                           forgetScriptsFrom(N_PRELUDE_SCRIPTS);
2030                           load();
2031                           break;
2032             case ALSO   : clearProject();
2033                           forgetScriptsFrom(numScripts);
2034                           load();
2035                           break;
2036             case RELOAD : readScripts(N_PRELUDE_SCRIPTS);
2037                           break;
2038             case PROJECT: project();
2039                           break;
2040             case SETMODULE :
2041                           setModule();
2042                           break;
2043             case EVAL   : evaluator();
2044                           break;
2045             case TYPEOF : showtype();
2046                           break;
2047             case BROWSE : browse();
2048                           break;
2049 #if EXPLAIN_INSTANCE_RESOLUTION
2050             case XPLAIN : xplain();
2051                           break;
2052 #endif
2053             case NAMES  : listNames();
2054                           break;
2055             case HELP   : menu();
2056                           break;
2057             case BADCMD : guidance();
2058                           break;
2059             case SET    : set();
2060                           break;
2061             case STATS:
2062 #ifdef CRUDE_PROFILING
2063                           cp_show();
2064 #endif
2065                           break;
2066             case SYSTEM : if (shellEsc(readLine()))
2067                               Printf("Warning: Shell escape terminated abnormally\n");
2068                           break;
2069             case CHGDIR : changeDir();
2070                           break;
2071             case INFO   : info();
2072                           break;
2073             case PNTVER: Printf("-- Hugs Version %s\n",
2074                                  HUGS_VERSION);
2075                           break;
2076             case DUMP   : dumpStg();
2077                           break;
2078             case QUIT   : return;
2079             case COLLECT: consGC = FALSE;
2080                           garbageCollect();
2081                           consGC = TRUE;
2082                           Printf("Garbage collection recovered %d cells\n",
2083                                  cellsRecovered);
2084                           break;
2085             case NOCMD  : break;
2086         }
2087 #ifdef WANT_TIMER
2088         updateTimers();
2089         Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
2090                millisecs(userElapsed), millisecs(systElapsed));
2091 #endif
2092         if (autoMain) break;
2093     }
2094     breakOn(FALSE);
2095 }
2096
2097 /* --------------------------------------------------------------------------
2098  * Display progress towards goal:
2099  * ------------------------------------------------------------------------*/
2100
2101 static Target currTarget;
2102 static Bool   aiming = FALSE;
2103 static Int    currPos;
2104 static Int    maxPos;
2105 static Int    charCount;
2106
2107 Void setGoal(what, t)                  /* Set goal for what to be t        */
2108 String what;
2109 Target t; {
2110     if (quiet)
2111       return;
2112 #if EXPLAIN_INSTANCE_RESOLUTION
2113     if (showInstRes)
2114       return;
2115 #endif
2116     currTarget = (t?t:1);
2117     aiming     = TRUE;
2118     if (useDots) {
2119         currPos = strlen(what);
2120         maxPos  = getTerminalWidth() - 1;
2121         Printf("%s",what);
2122     }
2123     else
2124         for (charCount=0; *what; charCount++)
2125             Putchar(*what++);
2126     FlushStdout();
2127 }
2128
2129 Void soFar(t)                          /* Indicate progress towards goal   */
2130 Target t; {                            /* has now reached t                */
2131     if (quiet)
2132       return;
2133 #if EXPLAIN_INSTANCE_RESOLUTION
2134     if (showInstRes)
2135       return;
2136 #endif
2137     if (useDots) {
2138         Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2139
2140         if (newPos>maxPos)
2141             newPos = maxPos;
2142
2143         if (newPos>currPos) {
2144             do
2145                 Putchar('.');
2146             while (newPos>++currPos);
2147             FlushStdout();
2148         }
2149         FlushStdout();
2150     }
2151 }
2152
2153 Void done() {                          /* Goal has now been achieved       */
2154     if (quiet)
2155       return;
2156 #if EXPLAIN_INSTANCE_RESOLUTION
2157     if (showInstRes)
2158       return;
2159 #endif
2160     if (useDots) {
2161         while (maxPos>currPos++)
2162             Putchar('.');
2163         Putchar('\n');
2164     }
2165     else
2166         for (; charCount>0; charCount--) {
2167             Putchar('\b');
2168             Putchar(' ');
2169             Putchar('\b');
2170         }
2171     aiming = FALSE;
2172     FlushStdout();
2173 }
2174
2175 static Void local failed() {           /* Goal cannot be reached due to    */
2176     if (aiming) {                      /* errors                           */
2177         aiming = FALSE;
2178         Putchar('\n');
2179         FlushStdout();
2180     }
2181 }
2182
2183 /* --------------------------------------------------------------------------
2184  * Error handling:
2185  * ------------------------------------------------------------------------*/
2186
2187 Cell errAssert(l)   /* message to use when raising asserts, etc */
2188 Int l; {
2189   char tmp[100];
2190   Cell str;
2191   if (scriptFile) {
2192     str = mkStr(findText(scriptFile));
2193   } else {
2194     str = mkStr(findText(""));
2195   }
2196   return (ap2(nameTangleMessage,str,mkInt(l)));
2197 }
2198
2199
2200 Void errHead(l)                        /* print start of error message     */
2201 Int l; {
2202     failed();                          /* failed to reach target ...       */
2203     stopAnyPrinting();
2204     FPrintf(errorStream,"ERROR");
2205
2206     if (scriptFile) {
2207         FPrintf(errorStream," \"%s\"", scriptFile);
2208         setLastEdit(scriptFile,l);
2209         if (l) FPrintf(errorStream," (line %d)",l);
2210         scriptFile = 0;
2211     }
2212     FPrintf(errorStream,": ");
2213     FFlush(errorStream);
2214 }
2215
2216 Void errFail() {                        /* terminate error message and     */
2217     Putc('\n',errorStream);             /* produce exception to return to  */
2218     FFlush(errorStream);                /* main command loop               */
2219     longjmp(catch_error,1);
2220 }
2221
2222 Void errAbort() {                       /* altern. form of error handling  */
2223     failed();                           /* used when suitable error message*/
2224     stopAnyPrinting();                  /* has already been printed        */
2225     errFail();
2226 }
2227
2228 Void internal(msg)                      /* handle internal error           */
2229 String msg; {
2230 #if HUGS_FOR_WINDOWS
2231     char buf[300];
2232     wsprintf(buf,"INTERNAL ERROR: %s",msg);
2233     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2234 #endif
2235     failed();
2236     stopAnyPrinting();
2237     Printf("INTERNAL ERROR: %s\n",msg);
2238     FlushStdout();
2239     longjmp(catch_error,1);
2240 }
2241
2242 Void fatal(msg)                         /* handle fatal error              */
2243 String msg; {
2244 #if HUGS_FOR_WINDOWS
2245     char buf[300];
2246     wsprintf(buf,"FATAL ERROR: %s",msg);
2247     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2248 #endif
2249     FlushStdout();
2250     Printf("\nFATAL ERROR: %s\n",msg);
2251     everybody(EXIT);
2252     exit(1);
2253 }
2254
2255 sigHandler(breakHandler) {              /* respond to break interrupt      */
2256 #if HUGS_FOR_WINDOWS
2257     MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
2258 #endif
2259     Hilite();
2260     Printf("{Interrupted!}\n");
2261     Lolite();
2262     breakOn(TRUE);  /* reinstall signal handler - redundant on BSD systems */
2263                     /* but essential on POSIX (and other?) systems         */
2264     everybody(BREAK);
2265     failed();
2266     stopAnyPrinting();
2267     FlushStdout();
2268     clearerr(stdin);
2269     longjmp(catch_error,1);
2270     sigResume;/*NOTREACHED*/
2271 }
2272
2273 /* --------------------------------------------------------------------------
2274  * Read value from environment variable or registry:
2275  * ------------------------------------------------------------------------*/
2276
2277 String fromEnv(var,def)         /* return value of:                        */
2278 String var;                     /*     environment variable named by var   */
2279 String def; {                   /* or: default value given by def          */
2280     String s = getenv(var);
2281     return (s ? s : def);
2282 }
2283
2284 /* --------------------------------------------------------------------------
2285  * String manipulation routines:
2286  * ------------------------------------------------------------------------*/
2287
2288 static String local strCopy(s)         /* make malloced copy of a string   */
2289 String s; {
2290     if (s && *s) {
2291         char *t, *r;
2292         if ((t=(char *)malloc(strlen(s)+1))==0) {
2293             ERRMSG(0) "String storage space exhausted"
2294             EEND;
2295         }
2296         for (r=t; (*r++ = *s++)!=0; ) {
2297         }
2298         return t;
2299     }
2300     return NULL;
2301 }
2302
2303 /* --------------------------------------------------------------------------
2304  * Compiler output
2305  * We can redirect compiler output (prompts, error messages, etc) by
2306  * tweaking these functions.
2307  * ------------------------------------------------------------------------*/
2308
2309 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2310
2311 #ifdef HAVE_STDARG_H
2312 #include <stdarg.h>
2313 #else
2314 #include <varargs.h>
2315 #endif
2316
2317 /* ----------------------------------------------------------------------- */
2318
2319 #define BufferSize 10000              /* size of redirected output buffer  */
2320
2321 typedef struct _HugsStream {
2322     char buffer[BufferSize];          /* buffer for redirected output      */
2323     Int  next;                        /* next space in buffer              */
2324 } HugsStream;
2325
2326 static Void   local vBufferedPrintf  ( HugsStream*, const char*, va_list );
2327 static Void   local bufferedPutchar  ( HugsStream*, Char );
2328 static String local bufferClear      ( HugsStream *stream );
2329
2330 static Void local vBufferedPrintf(stream, fmt, ap)
2331 HugsStream* stream;
2332 const char* fmt;
2333 va_list     ap; {
2334     Int spaceLeft = BufferSize - stream->next;
2335     char* p = &stream->buffer[stream->next];
2336     Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2337     if (0 <= charsAdded && charsAdded < spaceLeft)
2338         stream->next += charsAdded;
2339 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2340     else
2341         stream->next = 0;
2342 #endif
2343 }
2344
2345 static Void local bufferedPutchar(stream, c)
2346 HugsStream *stream;
2347 Char        c; {
2348     if (BufferSize - stream->next >= 2) {
2349         stream->buffer[stream->next++] = c;
2350         stream->buffer[stream->next] = '\0';
2351     }
2352 }
2353
2354 static String local bufferClear(stream)
2355 HugsStream *stream; {
2356     if (stream->next == 0) {
2357         return "";
2358     } else {
2359         stream->next = 0;
2360         return stream->buffer;
2361     }
2362 }
2363
2364 /* ----------------------------------------------------------------------- */
2365
2366 static HugsStream outputStreamH;
2367 /* ADR note:
2368  * We rely on standard C semantics to initialise outputStreamH.next to 0.
2369  */
2370
2371 Void hugsEnableOutput(f)
2372 Bool f; {
2373     disableOutput = !f;
2374 }
2375
2376 String hugsClearOutputBuffer() {
2377     return bufferClear(&outputStreamH);
2378 }
2379
2380 #ifdef HAVE_STDARG_H
2381 Void hugsPrintf(const char *fmt, ...) {
2382     va_list ap;                    /* pointer into argument list           */
2383     va_start(ap, fmt);             /* make ap point to first arg after fmt */
2384     if (!disableOutput) {
2385         vprintf(fmt, ap);
2386     } else {
2387         vBufferedPrintf(&outputStreamH, fmt, ap);
2388     }
2389     va_end(ap);                    /* clean up                             */
2390 }
2391 #else
2392 Void hugsPrintf(fmt, va_alist)
2393 const char *fmt;
2394 va_dcl {
2395     va_list ap;                    /* pointer into argument list           */
2396     va_start(ap);                  /* make ap point to first arg after fmt */
2397     if (!disableOutput) {
2398         vprintf(fmt, ap);
2399     } else {
2400         vBufferedPrintf(&outputStreamH, fmt, ap);
2401     }
2402     va_end(ap);                    /* clean up                             */
2403 }
2404 #endif
2405
2406 Void hugsPutchar(c)
2407 int c; {
2408     if (!disableOutput) {
2409         putchar(c);
2410     } else {
2411         bufferedPutchar(&outputStreamH, c);
2412     }
2413 }
2414
2415 Void hugsFlushStdout() {
2416     if (!disableOutput) {
2417         fflush(stdout);
2418     }
2419 }
2420
2421 Void hugsFFlush(fp)
2422 FILE* fp; {
2423     if (!disableOutput) {
2424         fflush(fp);
2425     }
2426 }
2427
2428 #ifdef HAVE_STDARG_H
2429 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2430     va_list ap;
2431     va_start(ap, fmt);
2432     if (!disableOutput) {
2433         vfprintf(fp, fmt, ap);
2434     } else {
2435         vBufferedPrintf(&outputStreamH, fmt, ap);
2436     }
2437     va_end(ap);
2438 }
2439 #else
2440 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2441 FILE* fp;
2442 const char* fmt;
2443 va_dcl {
2444     va_list ap;
2445     va_start(ap);
2446     if (!disableOutput) {
2447         vfprintf(fp, fmt, ap);
2448     } else {
2449         vBufferedPrintf(&outputStreamH, fmt, ap);
2450     }
2451     va_end(ap);
2452 }
2453 #endif
2454
2455 Void hugsPutc(c, fp)
2456 int   c;
2457 FILE* fp; {
2458     if (!disableOutput) {
2459         putc(c,fp);
2460     } else {
2461         bufferedPutchar(&outputStreamH, c);
2462     }
2463 }
2464
2465 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2466 /* --------------------------------------------------------------------------
2467  * Send message to each component of system:
2468  * ------------------------------------------------------------------------*/
2469
2470 Void everybody(what)            /* send command `what' to each component of*/
2471 Int what; {                     /* system to respond as appropriate ...    */
2472 #if 0
2473   fprintf ( stderr, "EVERYBODY %d\n", what );
2474 #endif
2475     machdep(what);              /* The order of calling each component is  */
2476     storage(what);              /* important for the PREPREL command       */
2477     substitution(what);
2478     input(what);
2479     translateControl(what);
2480     linkControl(what);
2481     staticAnalysis(what);
2482     deriveControl(what);
2483     typeChecker(what);
2484     compiler(what);
2485     codegen(what);
2486 }
2487
2488 /* --------------------------------------------------------------------------
2489  * Hugs for Windows code (WinMain and related functions)
2490  * ------------------------------------------------------------------------*/
2491
2492 #if HUGS_FOR_WINDOWS
2493 #include "winhugs.c"
2494 #endif