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