ghc/interpreter/hugs.c

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