ghc/interpreter/hugs.c

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