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