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.72 $
  13  * $Date: 2000/05/12 13:34:06 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include <setjmp.h>
  17 #include <ctype.h>
  18 #include <stdio.h>
  19
  20 #include "hugsbasictypes.h"
  21 #include "storage.h"
  22 #include "connect.h"
  23 #include "errors.h"
  24 #include "version.h"
  25
  26 #include "Rts.h"
  27 #include "RtsAPI.h"
  28 #include "Schedule.h"
  29 #include "Assembler.h"                                /* DEBUG_LoadSymbols */
  30 #include "ForeignCall.h"                                 /* createAdjThunk */
  31
  32
  33 Bool haskell98 = TRUE;                  /* TRUE => Haskell 98 compatibility*/
  34 Bool initDone = FALSE;
  35
  36 #if EXPLAIN_INSTANCE_RESOLUTION
  37 Bool showInstRes = FALSE;
  38 #endif
  39 #if MULTI_INST
  40 Bool multiInstRes = FALSE;
  41 #endif
  42
  43 /* --------------------------------------------------------------------------
  44  * Local function prototypes:
  45  * ------------------------------------------------------------------------*/
  46
  47 static List   local initialize        ( Int,String [] );
  48 static Void   local promptForInput    ( String );
  49 static Void   local interpreter       ( Int,String [] );
  50 static Void   local menu              ( Void );
  51 static Void   local guidance          ( Void );
  52 static Void   local forHelp           ( Void );
  53 static Void   local set               ( Void );
  54 static Void   local changeDir         ( Void );
  55 static Void   local load              ( Void );
  56 static Void   local project           ( Void );
  57 static Void   local editor            ( Void );
  58 static Void   local find              ( Void );
  59 static Bool   local startEdit         ( Int,String );
  60 static Void   local runEditor         ( Void );
  61 static Void   local setModule         ( Void );
  62 static Void   local evaluator         ( Void );
  63 static Void   local stopAnyPrinting   ( Void );
  64 static Void   local showtype          ( Void );
  65 static String local objToStr          ( Module, Cell );
  66 static Void   local info              ( Void );
  67 static Void   local printSyntax       ( Name );
  68 static Void   local showInst          ( Inst );
  69 static Void   local describe          ( Text );
  70 static Void   local listNames         ( Void );
  71
  72 static Void   local toggleSet         ( Char,Bool );
  73 static Void   local togglesIn         ( Bool );
  74 static Void   local optionInfo        ( Void );
  75 static Void   local readOptions       ( String );
  76 static Bool   local processOption     ( String );
  77 static Void   local setHeapSize       ( String );
  78 static Int    local argToInt          ( String );
  79
  80 static Void   local setLastEdit       ( String,Int );
  81 static Void   local failed            ( Void );
  82 static String local strCopy           ( String );
  83 static Void   local browseit          ( Module,String,Bool );
  84 static Void   local browse            ( Void );
  85 static void   local clearCurrentFile  ( void );
  86
  87 static void loadActions ( List loadModules /* :: [CONID] */ );
  88 static void addActions ( List extraModules /* :: [CONID] */ );
  89 static Bool loadThePrelude ( void );
  90
  91
  92 /* --------------------------------------------------------------------------
  93  * Machine dependent code for Hugs interpreter:
  94  * ------------------------------------------------------------------------*/
  95
  96 #include "machdep.c"
  97
  98 /* --------------------------------------------------------------------------
  99  * Local data areas:
 100  * ------------------------------------------------------------------------*/
 101
 102 static Bool   printing      = FALSE;    /* TRUE => currently printing value*/
 103 static Bool   showStats     = FALSE;    /* TRUE => print stats after eval  */
 104 static Bool   listScripts   = TRUE;   /* TRUE => list scripts after loading*/
 105 static Bool   addType       = FALSE;    /* TRUE => print type with value   */
 106 static Bool   useDots       = RISCOS;   /* TRUE => use dots in progress    */
 107 static Bool   quiet         = FALSE;    /* TRUE => don't show progress     */
 108 static Bool   lastWasObject = FALSE;
 109
 110        Bool   flagAssert    = FALSE;    /* TRUE => assert False <e> causes
 111                                                    an assertion failure    */
 112        Bool   preludeLoaded = FALSE;
 113        Bool   debugSC       = FALSE;
 114        Bool   combined      = FALSE;
 115
 116        Module moduleBeingParsed;        /* so the parser (topModule) knows */
 117 static char*  currentFile;              /* Name of current file, or NULL   */
 118 static char   currentFileName[1000];    /* name is stored here if it exists*/
 119
 120 static Bool   autoMain   = FALSE;
 121 static String lastEdit   = 0;           /* Name of script to edit (if any) */
 122 static Int    lastEdLine = 0;           /* Editor line number (if possible)*/
 123 static String prompt     = 0;           /* Prompt string                   */
 124 static Int    hpSize     = DEFAULTHEAP; /* Desired heap size               */
 125 static Bool   disableOutput = FALSE;    /* TRUE => quiet                   */
 126        String hugsEdit   = 0;           /* String for editor command       */
 127        String hugsPath   = 0;           /* String for file search path     */
 128
 129        List  ifaces_outstanding = NIL;
 130
 131 static ConId currentModule_failed = NIL; /* Remember failed module from :r */
 132
 133
 134
 135 /* --------------------------------------------------------------------------
 136  * Hugs entry point:
 137  * ------------------------------------------------------------------------*/
 138
 139 #ifdef DIET_HEP
 140
 141 #include "DietHEP.h"
 142
 143 static int diet_hep_initialised = 0;
 144
 145 static
 146 void diet_hep_initialise ( void* cstackbase )
 147 {
 148     List   modConIds; /* :: [CONID] */
 149     Bool   prelOK;
 150     String s;
 151     String fakeargv[1] = { "diet_hep" };
 152
 153     if (diet_hep_initialised) return;
 154     diet_hep_initialised = 1;
 155
 156     CStackBase = cstackbase;
 157     EnableOutput(1);
 158     setInstallDir ( "diet_hep" );
 159
 160     /* The following copied from interpreter() */
 161     setBreakAction ( HugsIgnoreBreak );
 162     modConIds = initialize(1,fakeargv);
 163     assert(isNull(modConIds));
 164     setBreakAction ( HugsIgnoreBreak );
 165     prelOK    = loadThePrelude();
 166
 167     if (!prelOK) {
 168        fprintf(stderr, "diet_hep_initialise: fatal error: "
 169                        "can't load the Prelude.\n" );
 170        exit(1);
 171     }
 172
 173     loadActions(NIL);
 174
 175     if (combined) everybody(POSTPREL);
 176     /* we now leave, and wait for requests */
 177 }
 178
 179
 180 static
 181 HMODULE LoadLibrary_wrk ( LPCSTR modname )
 182 {
 183    Text   t;
 184    Module m;
 185    t = findText(modname);
 186    addActions ( singleton(mkCon(t)) );
 187    m = findModule(t);
 188    if (isModule(m)) return m; else return 0;
 189 }
 190
 191 HMODULE LoadLibrary ( LPCSTR modname )
 192 {
 193    int xxx;
 194    HMODULE hdl;
 195    diet_hep_initialise ( &xxx );
 196    hdl = LoadLibrary_wrk ( modname );
 197    printf ( "hdl = %d\n", hdl );
 198    return hdl;
 199 }
 200
 201
 202 static
 203 void* GetProcAddr_wrk ( DHCALLCONV cconv,
 204                         HMODULE    hModule,
 205                         LPCSTR     lpProcName )
 206 {
 207    Name  n;
 208    Text  typedescr;
 209    void* adj_thunk;
 210    StgStablePtr stableptr;
 211
 212    if (!isModule(hModule)) return NULL;
 213    setCurrModule(hModule);
 214    n = findName ( findText(lpProcName) );
 215    if (!isName(n)) return NULL;
 216    assert(isCPtr(name(n).closure));
 217
 218    /* n is the function which we want to f-x-d,
 219       n :: prim_arg* -> IO prim_result.
 220       Assume that name(n).closure is a cptr which points to n's BCO.
 221
 222       Make ns a stable pointer to n.
 223       Manufacture a type descriptor string for n's type.
 224       use createAdjThunk to build the adj thunk.
 225    */
 226    typedescr = makeTypeDescrText ( name(n).type );
 227    if (!isText(typedescr)) return NULL;
 228    if (cconv != dh_stdcall && cconv != dh_ccall) return NULL;
 229
 230    stableptr = getStablePtr( cptrOf(name(n).closure) );
 231    adj_thunk = createAdjThunk ( stableptr,
 232                                 textToStr(typedescr),
 233                                 cconv==dh_stdcall ? 's' : 'c' );
 234    return adj_thunk;
 235 }
 236
 237 void* GetProcAddr ( DHCALLCONV cconv,
 238                     HMODULE    hModule,
 239                     LPCSTR     lpProcName )
 240 {
 241    int xxx;
 242    diet_hep_initialise ( &xxx );
 243    return GetProcAddr_wrk ( cconv, hModule, lpProcName );
 244 }
 245
 246 //---------------------------------
 247 //--- testing it ...
 248 int main ( int argc, char** argv )
 249 {
 250    void*   proc;
 251    HMODULE hdl;
 252    hdl = LoadLibrary("FooBar");
 253    assert(isModule(hdl));
 254    proc = GetProcAddr ( dh_ccall, hdl, "wurble" );
 255 fprintf ( stderr, "just before calling it\n");
 256    ((void(*)(int)) proc)  (33);
 257    ((void(*)(int)) proc)  (34);
 258    ((void(*)(int)) proc)  (35);
 259    fprintf ( stderr, "exiting safely\n");
 260    return 0;
 261 }
 262
 263 #else
 264
 265 Main main ( Int, String [] );       /* now every func has a prototype  */
 266
 267 Main main(argc,argv)
 268 int  argc;
 269 char *argv[]; {
 270     CStackBase = &argc;                 /* Save stack base for use in gc   */
 271
 272 #   ifdef DEBUG
 273 #   if 0
 274     checkBytecodeCount();               /* check for too many bytecodes    */
 275 #   endif
 276 #   endif
 277
 278     /* If first arg is +Q or -Q, be entirely silent, and automatically run
 279        main after loading scripts.  Useful for running the nofib suite.    */
 280     if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
 281        autoMain = TRUE;
 282        if (strcmp(argv[1],"-Q") == 0) {
 283          EnableOutput(0);
 284        }
 285     }
 286
 287     Printf("__   __ __  __  ____   ___      _________________________________________\n");
 288     Printf("||   || ||  || ||  || ||__      STGHugs: Based on the Haskell 98 standard\n");
 289     Printf("||___|| ||__|| ||__||  __||     Copyright (c) 1994-2000\n");
 290     Printf("||---||         ___||           World Wide Web: http://haskell.org/hugs\n");
 291     Printf("||   ||                         Report bugs to: hugs-bugs@haskell.org\n");
 292     Printf("||   || Version: %s _________________________________________\n\n",HUGS_VERSION);
 293
 294     /* Get the absolute path to the directory containing the hugs
 295        executable, so that we know where the Prelude and nHandle.so/.dll are.
 296        We do this by reading env var STGHUGSDIR.  This needs to succeed, so
 297        setInstallDir won't return unless it succeeds.
 298     */
 299     setInstallDir ( argv[0] );
 300
 301     FlushStdout();
 302     interpreter(argc,argv);
 303     Printf("[Leaving Hugs]\n");
 304     everybody(EXIT);
 305     shutdownHaskell();
 306     FlushStdout();
 307     fflush(stderr);
 308     exit(0);
 309     MainDone();
 310 }
 311
 312 #endif /* DIET_HEP */
 313
 314 /* --------------------------------------------------------------------------
 315  * Initialization, interpret command line args and read prelude:
 316  * ------------------------------------------------------------------------*/
 317
 318 static List /*CONID*/ initialize ( Int argc, String argv[] )
 319 {
 320    Int    i, j;
 321    List   initialModules;
 322
 323    setLastEdit((String)0,0);
 324    lastEdit      = 0;
 325    currentFile   = NULL;
 326
 327 #if SYMANTEC_C
 328    hugsEdit      = "";
 329 #else
 330    hugsEdit      = strCopy(fromEnv("EDITOR",NULL));
 331 #endif
 332    hugsPath      = strCopy(HUGSPATH);
 333    readOptions("-p\"%s> \" -r$$");
 334    readOptions(fromEnv("STGHUGSFLAGS",""));
 335
 336 #  if DEBUG
 337    {
 338       char exe_name[N_INSTALLDIR + 6];
 339       strcpy(exe_name, installDir);
 340       strcat(exe_name, "hugs");
 341       DEBUG_LoadSymbols(exe_name);
 342    }
 343 #  endif
 344
 345    /* startupHaskell extracts args between +RTS ... -RTS, and sets
 346       prog_argc/prog_argv to the rest.  We want to further process
 347       the rest, so we then get hold of them again.
 348    */
 349    startupHaskell ( argc, argv, NULL );
 350    getProgArgv ( &argc, &argv );
 351
 352    /* Find out early on if we're in combined mode or not.
 353       everybody(PREPREL) needs to know this.  Also, establish the
 354       heap size;
 355    */
 356    for (i = 1; i < argc; ++i) {
 357       if (strcmp(argv[i], "--")==0) break;
 358       if (strcmp(argv[i], "-c")==0) combined = FALSE;
 359       if (strcmp(argv[i], "+c")==0) combined = TRUE;
 360
 361       if (strncmp(argv[i],"+h",2)==0 || strncmp(argv[i],"-h",2)==0)
 362          setHeapSize(&(argv[i][2]));
 363    }
 364
 365    everybody(PREPREL);
 366    initialModules = NIL;
 367
 368    for (i = 1; i < argc; ++i) {          /* process command line arguments  */
 369       if (strcmp(argv[i], "--")==0)
 370          { argv[i] = NULL; break; }
 371       if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/) {
 372          if (!processOption(argv[i]))
 373             initialModules
 374                = cons ( mkCon(findText(argv[i])), initialModules );
 375          argv[i] = NULL;
 376       }
 377    }
 378
 379    if (haskell98) {
 380        Printf("Haskell 98 mode: Restart with command line option -98"
 381               " to enable extensions\n");
 382    } else {
 383        Printf("Hugs mode: Restart with command line option +98 for"
 384               " Haskell 98 mode\n");
 385    }
 386
 387    if (combined) {
 388        Printf("Combined mode: Restart with command line -c for"
 389               " standalone mode\n\n" );
 390    } else {
 391        Printf("Standalone mode: Restart with command line +c for"
 392               " combined mode\n\n" );
 393    }
 394
 395    /* slide args back over the deleted ones. */
 396    j = 1;
 397    for (i = 1; i < argc; i++)
 398       if (argv[i])
 399          argv[j++] = argv[i];
 400
 401    argc = j;
 402
 403    setProgArgv ( argc, argv );
 404
 405    initDone = TRUE;
 406    return initialModules;
 407 }
 408
 409 /* --------------------------------------------------------------------------
 410  * Command line options:
 411  * ------------------------------------------------------------------------*/
 412
 413 struct options {                        /* command line option toggles     */
 414     char   c;                           /* table defined in main app.      */
 415     int    h98;
 416     String description;
 417     Bool   *flag;
 418 };
 419 extern struct options toggle[];
 420
 421 static Void local toggleSet(c,state)    /* Set command line toggle         */
 422 Char c;
 423 Bool state; {
 424     Int i;
 425     for (i=0; toggle[i].c; ++i)
 426         if (toggle[i].c == c) {
 427             *toggle[i].flag = state;
 428             return;
 429         }
 430     clearCurrentFile();
 431     ERRMSG(0) "Unknown toggle `%c'", c
 432     EEND_NO_LONGJMP;
 433 }
 434
 435 static Void local togglesIn(state)      /* Print current list of toggles in*/
 436 Bool state; {                           /* given state                     */
 437     Int count = 0;
 438     Int i;
 439     for (i=0; toggle[i].c; ++i)
 440         if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
 441             if (count==0)
 442                 Putchar((char)(state ? '+' : '-'));
 443             Putchar(toggle[i].c);
 444             count++;
 445         }
 446     if (count>0)
 447         Putchar(' ');
 448 }
 449
 450 static Void local optionInfo() {        /* Print information about command */
 451     static String fmts = "%-5s%s\n";    /* line settings                   */
 452     static String fmtc = "%-5c%s\n";
 453     Int    i;
 454
 455     Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
 456     for (i=0; toggle[i].c; ++i) {
 457         if (!haskell98 || toggle[i].h98) {
 458             Printf(fmtc,toggle[i].c,toggle[i].description);
 459         }
 460     }
 461
 462     Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
 463     Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
 464     Printf(fmts,"pstr","Set prompt string to str");
 465     Printf(fmts,"rstr","Set repeat last expression string to str");
 466     Printf(fmts,"Pstr","Set search path for modules to str");
 467     Printf(fmts,"Estr","Use editor setting given by str");
 468     Printf(fmts,"cnum","Set constraint cutoff limit");
 469 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 470     Printf(fmts,"Fstr","Set preprocessor filter to str");
 471 #endif
 472
 473     Printf("\nCurrent settings: ");
 474     togglesIn(TRUE);
 475     togglesIn(FALSE);
 476     Printf("-h%d",heapSize);
 477     Printf(" -p");
 478     printString(prompt);
 479     Printf(" -r");
 480     printString(repeatStr);
 481     Printf(" -c%d",cutoff);
 482     Printf("\nSearch path     : -P");
 483     printString(hugsPath);
 484 #if 0
 485 ToDo
 486     if (projectPath!=NULL) {
 487         Printf("\nProject Path    : %s",projectPath);
 488     }
 489 #endif
 490     Printf("\nEditor setting  : -E");
 491     printString(hugsEdit);
 492 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 493     Printf("\nPreprocessor    : -F");
 494     printString(preprocessor);
 495 #endif
 496     Printf("\nCompatibility   : %s", haskell98 ? "Haskell 98 (+98)"
 497                                                : "Hugs Extensions (-98)");
 498     Putchar('\n');
 499 }
 500
 501 #undef PUTC
 502 #undef PUTS
 503 #undef PUTInt
 504 #undef PUTStr
 505
 506 static Void local readOptions(options)         /* read options from string */
 507 String options; {
 508     String s;
 509     if (options) {
 510         stringInput(options);
 511         while ((s=readFilename())!=0) {
 512             if (*s && !processOption(s)) {
 513                 ERRMSG(0) "Option string must begin with `+' or `-'"
 514                 EEND;
 515             }
 516         }
 517     }
 518 }
 519
 520 static Bool local processOption(s)      /* process string s for options,   */
 521 String s; {                             /* return FALSE if none found.     */
 522     Bool state;
 523
 524     if (s[0]=='-')
 525         state = FALSE;
 526     else if (s[0]=='+')
 527         state = TRUE;
 528     else
 529         return FALSE;
 530
 531     while (*++s)
 532         switch (*s) {
 533             case 'Q' : break;                           /* already handled */
 534
 535             case 'p' : if (s[1]) {
 536                            if (prompt) free(prompt);
 537                            prompt = strCopy(s+1);
 538                        }
 539                        return TRUE;
 540
 541             case 'r' : if (s[1]) {
 542                            if (repeatStr) free(repeatStr);
 543                            repeatStr = strCopy(s+1);
 544                        }
 545                        return TRUE;
 546
 547             case 'P' : {
 548                            String p = substPath(s+1,hugsPath ? hugsPath : "");
 549                            if (hugsPath) free(hugsPath);
 550                            hugsPath = p;
 551                            return TRUE;
 552                        }
 553
 554             case 'E' : if (hugsEdit) free(hugsEdit);
 555                        hugsEdit = strCopy(s+1);
 556                        return TRUE;
 557
 558 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 559             case 'F' : if (preprocessor) free(preprocessor);
 560                        preprocessor = strCopy(s+1);
 561                        return TRUE;
 562 #endif
 563
 564             case 'h' : /* don't do anything, since pre-scan of args
 565                        will have got it already */
 566                        return TRUE;
 567
 568             case 'c' :  /* don't do anything, since pre-scan of args
 569                            will have got it already */
 570                        return TRUE;
 571
 572             case 'D' : /* hack */
 573                 {
 574                     extern void setRtsFlags( int x );
 575                     setRtsFlags(argToInt(s+1));
 576                     return TRUE;
 577                 }
 578
 579             default  : if (strcmp("98",s)==0) {
 580                            if (initDone && ((state && !haskell98) ||
 581                                                (!state && haskell98))) {
 582                                FPrintf(stderr,
 583                                        "Haskell 98 compatibility cannot be changed"
 584                                        " while the interpreter is running\n");
 585                            } else {
 586                                haskell98 = state;
 587                            }
 588                            return TRUE;
 589                        } else {
 590                            toggleSet(*s,state);
 591                        }
 592                        break;
 593         }
 594     return TRUE;
 595 }
 596
 597 static Void local setHeapSize(s)
 598 String s; {
 599     if (s) {
 600         hpSize = argToInt(s);
 601         if (hpSize < MINIMUMHEAP)
 602             hpSize = MINIMUMHEAP;
 603         else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
 604             hpSize = MAXIMUMHEAP;
 605         if (initDone && hpSize != heapSize) {
 606             /* ToDo: should this use a message box in winhugs? */
 607             FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
 608         } else {
 609             heapSize = hpSize;
 610         }
 611     }
 612 }
 613
 614 static Int local argToInt(s)            /* read integer from argument str  */
 615 String s; {
 616     Int    n = 0;
 617     String t = s;
 618
 619     if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
 620         ERRMSG(0) "Missing integer in option setting \"%s\"", t
 621         EEND;
 622     }
 623
 624     do {
 625         Int d = (*s++) - '0';
 626         if (n > ((MAXPOSINT - d)/10)) {
 627             ERRMSG(0) "Option setting \"%s\" is too large", t
 628             EEND;
 629         }
 630         n     = 10*n + d;
 631     } while (isascii((int)(*s)) && isdigit((int)(*s)));
 632
 633     if (*s=='K' || *s=='k') {
 634         if (n > (MAXPOSINT/1000)) {
 635             ERRMSG(0) "Option setting \"%s\" is too large", t
 636             EEND;
 637         }
 638         n *= 1000;
 639         s++;
 640     }
 641
 642 #if MAXPOSINT > 1000000                 /* waste of time on 16 bit systems */
 643     if (*s=='M' || *s=='m') {
 644         if (n > (MAXPOSINT/1000000)) {
 645             ERRMSG(0) "Option setting \"%s\" is too large", t
 646             EEND;
 647         }
 648         n *= 1000000;
 649         s++;
 650     }
 651 #endif
 652
 653 #if MAXPOSINT > 1000000000
 654     if (*s=='G' || *s=='g') {
 655         if (n > (MAXPOSINT/1000000000)) {
 656             ERRMSG(0) "Option setting \"%s\" is too large", t
 657             EEND;
 658         }
 659         n *= 1000000000;
 660         s++;
 661     }
 662 #endif
 663
 664     if (*s!='\0') {
 665         ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
 666         EEND;
 667     }
 668
 669     return n;
 670 }
 671
 672 /* --------------------------------------------------------------------------
 673  * Print Menu of list of commands:
 674  * ------------------------------------------------------------------------*/
 675
 676 static struct cmd cmds[] = {
 677  {":?",      HELP},   {":cd",   CHGDIR},  {":also",    ALSO},
 678  {":type",   TYPEOF}, {":!",    SYSTEM},  {":load",    LOAD},
 679  {":reload", RELOAD}, {":gc",   COLLECT}, {":edit",    EDIT},
 680  {":quit",   QUIT},   {":set",  SET},     {":find",    FIND},
 681  {":names",  NAMES},  {":info", INFO},    {":project", PROJECT},
 682  {":dump",   DUMP},
 683  {":module", SETMODULE},
 684  {":browse", BROWSE},
 685 #if EXPLAIN_INSTANCE_RESOLUTION
 686  {":xplain", XPLAIN},
 687 #endif
 688  {":version", PNTVER},
 689  {"",      EVAL},
 690  {0,0}
 691 };
 692
 693 static Void local menu() {
 694     Printf("LIST OF COMMANDS:  Any command may be abbreviated to :c where\n");
 695     Printf("c is the first character in the full name.\n\n");
 696     Printf(":load <filenames>   load modules from specified files\n");
 697     Printf(":load               clear all files except prelude\n");
 698     Printf(":also <filenames>   read additional modules\n");
 699     Printf(":reload             repeat last load command\n");
 700     Printf(":project <filename> use project file\n");
 701     Printf(":edit <filename>    edit file\n");
 702     Printf(":edit               edit last module\n");
 703     Printf(":module <module>    set module for evaluating expressions\n");
 704     Printf("<expr>              evaluate expression\n");
 705     Printf(":type <expr>        print type of expression\n");
 706     Printf(":?                  display this list of commands\n");
 707     Printf(":set <options>      set command line options\n");
 708     Printf(":set                help on command line options\n");
 709     Printf(":names [pat]        list names currently in scope\n");
 710     Printf(":info <names>       describe named objects\n");
 711     Printf(":browse <modules>   browse names defined in <modules>\n");
 712 #if EXPLAIN_INSTANCE_RESOLUTION
 713     Printf(":xplain <context>   explain instance resolution for <context>\n");
 714 #endif
 715     Printf(":find <name>        edit module containing definition of name\n");
 716     Printf(":!command           shell escape\n");
 717     Printf(":cd dir             change directory\n");
 718     Printf(":gc                 force garbage collection\n");
 719     Printf(":version            print Hugs version\n");
 720     Printf(":dump <name>        print STG code for named fn\n");
 721     Printf(":quit               exit Hugs interpreter\n");
 722 }
 723
 724 static Void local guidance() {
 725     Printf("Command not recognised.  ");
 726     forHelp();
 727 }
 728
 729 static Void local forHelp() {
 730     Printf("Type :? for help\n");
 731 }
 732
 733 /* --------------------------------------------------------------------------
 734  * Setting of command line options:
 735  * ------------------------------------------------------------------------*/
 736
 737 struct options toggle[] = {             /* List of command line toggles    */
 738     {'s', 1, "Print no. reductions/cells after eval", &showStats},
 739     {'t', 1, "Print type after evaluation",           &addType},
 740     {'g', 1, "Print no. cells recovered after gc",    &gcMessages},
 741     {'l', 1, "Literate modules as default",           &literateScripts},
 742     {'e', 1, "Warn about errors in literate modules", &literateErrors},
 743     {'.', 1, "Print dots to show progress",           &useDots},
 744     {'q', 1, "Print nothing to show progress",        &quiet},
 745     {'w', 1, "Always show which modules are loaded",  &listScripts},
 746     {'k', 1, "Show kind errors in full",              &kindExpert},
 747     {'o', 0, "Allow overlapping instances",           &allowOverlap},
 748     {'S', 1, "Debug: show generated SC code",         &debugSC},
 749     {'a', 1, "Raise exception on assert failure",     &flagAssert},
 750 #if EXPLAIN_INSTANCE_RESOLUTION
 751     {'x', 1, "Explain instance resolution",           &showInstRes},
 752 #endif
 753 #if MULTI_INST
 754     {'m', 0, "Use multi instance resolution",         &multiInstRes},
 755 #endif
 756     {0,   0, 0,                                       0}
 757 };
 758
 759 static Void local set() {               /* change command line options from*/
 760     String s;                           /* Hugs command line               */
 761
 762     if ((s=readFilename())!=0) {
 763         do {
 764             if (!processOption(s)) {
 765                 ERRMSG(0) "Option string must begin with `+' or `-'"
 766                 EEND_NO_LONGJMP;
 767             }
 768         } while ((s=readFilename())!=0);
 769     }
 770     else
 771         optionInfo();
 772 }
 773
 774 /* --------------------------------------------------------------------------
 775  * Change directory command:
 776  * ------------------------------------------------------------------------*/
 777
 778 static Void local changeDir() {         /* change directory                */
 779     String s = readFilename();
 780     if (s && chdir(s)) {
 781         ERRMSG(0) "Unable to change to directory \"%s\"", s
 782         EEND_NO_LONGJMP;
 783     }
 784 }
 785
 786
 787 /* --------------------------------------------------------------------------
 788  * Interrupt handling
 789  * ------------------------------------------------------------------------*/
 790
 791 static jmp_buf catch_error;             /* jump buffer for error trapping  */
 792
 793 HugsBreakAction currentBreakAction = HugsIgnoreBreak;
 794
 795 static void handler_IgnoreBreak ( int sig )
 796 {
 797    setHandler ( handler_IgnoreBreak );
 798 }
 799
 800 static void handler_LongjmpOnBreak ( int sig )
 801 {
 802    setHandler ( handler_LongjmpOnBreak );
 803    Printf("{Interrupted!}\n");
 804    longjmp(catch_error,1);
 805 }
 806
 807 static void handler_RtsInterrupt ( int sig )
 808 {
 809    setHandler ( handler_RtsInterrupt );
 810    interruptStgRts();
 811 }
 812
 813 HugsBreakAction setBreakAction ( HugsBreakAction newAction )
 814 {
 815    HugsBreakAction tmp = currentBreakAction;
 816    currentBreakAction = newAction;
 817    switch (newAction) {
 818       case HugsIgnoreBreak:
 819          setHandler ( handler_IgnoreBreak ); break;
 820       case HugsLongjmpOnBreak:
 821          setHandler ( handler_LongjmpOnBreak ); break;
 822       case HugsRtsInterrupt:
 823          setHandler ( handler_RtsInterrupt ); break;
 824       default:
 825          internal("setBreakAction");
 826    }
 827    return tmp;
 828 }
 829
 830
 831 /* --------------------------------------------------------------------------
 832  * The new module chaser, loader, etc
 833  * ------------------------------------------------------------------------*/
 834
 835 List    moduleGraph   = NIL;
 836 List    prelModules   = NIL;
 837 List    targetModules = NIL;
 838
 839 static String modeToString ( Cell mode )
 840 {
 841    switch (mode) {
 842       case FM_SOURCE: return "source";
 843       case FM_OBJECT: return "object";
 844       case FM_EITHER: return "source or object";
 845       default: internal("modeToString");
 846    }
 847 }
 848
 849 static Cell childMode ( Cell modeMeRequest, Cell modeMeActual )
 850 {
 851    assert(modeMeActual == FM_SOURCE ||
 852           modeMeActual == FM_OBJECT);
 853    assert(modeMeRequest == FM_SOURCE ||
 854           modeMeRequest == FM_OBJECT ||
 855           modeMeRequest == FM_EITHER);
 856    if (modeMeRequest == FM_SOURCE) return modeMeRequest;
 857    if (modeMeRequest == FM_OBJECT) return modeMeRequest;
 858    if (modeMeActual == FM_OBJECT) return FM_OBJECT;
 859    if (modeMeActual == FM_SOURCE) return FM_EITHER;
 860    internal("childMode");
 861 }
 862
 863 static Bool compatibleNewMode ( Cell modeNew, Cell modeExisting )
 864 {
 865    if (modeNew == FM_OBJECT && modeExisting == FM_OBJECT) return TRUE;
 866    if (modeNew == FM_SOURCE && modeExisting == FM_SOURCE) return TRUE;
 867    if (modeNew == FM_EITHER && modeExisting == FM_OBJECT) return TRUE;
 868    if (modeNew == FM_EITHER && modeExisting == FM_SOURCE) return TRUE;
 869    return FALSE;
 870 }
 871
 872 static void setCurrentFile ( Module mod )
 873 {
 874    assert(isModule(mod));
 875    strncpy(currentFileName, textToStr(module(mod).text), 990);
 876    strcat(currentFileName, textToStr(module(mod).srcExt));
 877    currentFile       = currentFileName;
 878    moduleBeingParsed = mod;
 879 }
 880
 881 static void clearCurrentFile ( void )
 882 {
 883    currentFile       = NULL;
 884    moduleBeingParsed = NIL;
 885 }
 886
 887 static void ppMG ( void )
 888 {
 889    List t,u,v;
 890    for (t = moduleGraph; nonNull(t); t=tl(t)) {
 891       u = hd(t);
 892       switch (whatIs(u)) {
 893          case GRP_NONREC:
 894             FPrintf ( stderr, "  %s\n", textToStr(textOf(snd(u))));
 895             break;
 896          case GRP_REC:
 897             FPrintf ( stderr, "  {" );
 898             for (v = snd(u); nonNull(v); v=tl(v))
 899                FPrintf ( stderr, "%s ", textToStr(textOf(hd(v))) );
 900             FPrintf ( stderr, "}\n" );
 901             break;
 902          default:
 903             internal("ppMG");
 904       }
 905    }
 906 }
 907
 908
 909 static Bool elemMG ( ConId mod )
 910 {
 911    List gs;
 912    for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
 913      switch (whatIs(hd(gs))) {
 914         case GRP_NONREC:
 915            if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
 916            break;
 917         case GRP_REC:
 918            if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
 919            break;
 920         default:
 921            internal("elemMG");
 922      }
 923   return FALSE;
 924 }
 925
 926
 927 static ConId selectArbitrarilyFromGroup ( Cell group )
 928 {
 929    switch (whatIs(group)) {
 930       case GRP_NONREC: return snd(group);
 931       case GRP_REC:    return hd(snd(group));
 932       default:         internal("selectArbitrarilyFromGroup");
 933    }
 934 }
 935
 936 static ConId selectLatestMG ( void )
 937 {
 938    List gs = moduleGraph;
 939    if (isNull(gs)) internal("selectLatestMG(1)");
 940    while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
 941    return selectArbitrarilyFromGroup(hd(gs));
 942 }
 943
 944
 945 static List /* of CONID */ listFromSpecifiedMG ( List mg )
 946 {
 947    List gs;
 948    List cs = NIL;
 949    for (gs = mg; nonNull(gs); gs=tl(gs)) {
 950       switch (whatIs(hd(gs))) {
 951         case GRP_REC:    cs = appendOnto(cs,snd(hd(gs))); break;
 952         case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
 953         default:         internal("listFromSpecifiedMG");
 954       }
 955    }
 956    return cs;
 957 }
 958
 959 static List /* of CONID */ listFromMG ( void )
 960 {
 961    return listFromSpecifiedMG ( moduleGraph );
 962 }
 963
 964
 965 /* Calculate the strongly connected components of modgList
 966    and assign them to moduleGraph.  Uses the .uses field of
 967    each of the modules to build the graph structure.
 968 */
 969 #define  SCC             modScc          /* make scc algorithm for StgVars */
 970 #define  LOWLINK         modLowlink
 971 #define  DEPENDS(t)      snd(t)
 972 #define  SETDEPENDS(c,v) snd(c)=v
 973 #include "scc.c"
 974 #undef   SETDEPENDS
 975 #undef   DEPENDS
 976 #undef   LOWLINK
 977 #undef   SCC
 978
 979 static void mgFromList ( List /* of CONID */ modgList )
 980 {
 981    List   t;
 982    List   u;
 983    Text   mT;
 984    List   usesT;
 985    List   adjList; /* :: [ (Text, [Text]) ] */
 986    Module mod;
 987    List   scc;
 988    Bool   isRec;
 989
 990    adjList = NIL;
 991    for (t = modgList; nonNull(t); t=tl(t)) {
 992       mT = textOf(hd(t));
 993       mod = findModule(mT);
 994       assert(nonNull(mod));
 995       usesT = NIL;
 996       for (u = module(mod).uses; nonNull(u); u=tl(u))
 997          usesT = cons(textOf(hd(u)),usesT);
 998
 999       /* artificially give all modules a dependency on Prelude */
1000       if (mT != textPrelude && mT != textPrelPrim)
1001          usesT = cons(textPrelude,usesT);
1002       adjList = cons(pair(mT,usesT),adjList);
1003    }
1004
1005    /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
1006       Modify this so that the adjacency list is a list of pointers
1007       back to bits of adjList -- that's what modScc needs.
1008    */
1009    for (t = adjList; nonNull(t); t=tl(t)) {
1010       List adj = NIL;
1011       /* for each elem of the adjacency list ... */
1012       for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
1013          List v;
1014          Text a = hd(u);
1015          /* find the element of adjList whose fst is a */
1016          for (v = adjList; nonNull(v); v=tl(v)) {
1017             assert(isText(a));
1018             assert(isText(fst(hd(v))));
1019             if (fst(hd(v))==a) break;
1020          }
1021          if (isNull(v)) internal("mgFromList");
1022          adj = cons(hd(v),adj);
1023       }
1024       snd(hd(t)) = adj;
1025    }
1026
1027    adjList = modScc ( adjList );
1028    /* adjList is now [ [(module-text, aux-info-field)] ] */
1029
1030    moduleGraph = NIL;
1031
1032    for (t = adjList; nonNull(t); t=tl(t)) {
1033
1034       scc = hd(t);
1035       /* scc :: [ (module-text, aux-info-field) ] */
1036       for (u = scc; nonNull(u); u=tl(u))
1037          hd(u) = mkCon(fst(hd(u)));
1038
1039       /* scc :: [CONID] */
1040       if (length(scc) > 1) {
1041          isRec = TRUE;
1042       } else {
1043          /* singleton module in scc; does it import itself? */
1044          mod = findModule ( textOf(hd(scc)) );
1045          assert(nonNull(mod));
1046          isRec = FALSE;
1047          for (u = module(mod).uses; nonNull(u); u=tl(u))
1048             if (textOf(hd(u))==textOf(hd(scc)))
1049                isRec = TRUE;
1050       }
1051
1052       if (isRec)
1053          moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
1054          moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
1055    }
1056    moduleGraph = reverse(moduleGraph);
1057 }
1058
1059
1060 static List /* of CONID */ getModuleImports ( Cell tree )
1061 {
1062    Cell  te;
1063    List  tes;
1064    ConId use;
1065    List  uses = NIL;
1066    for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
1067       te = hd(tes);
1068       switch(whatIs(te)) {
1069          case M_IMPORT_Q:
1070             use = zfst(unap(M_IMPORT_Q,te));
1071             assert(isCon(use));
1072             if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1073             break;
1074          case M_IMPORT_UNQ:
1075             use = zfst(unap(M_IMPORT_UNQ,te));
1076             assert(isCon(use));
1077             if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1078             break;
1079          default:
1080             break;
1081       }
1082    }
1083    return uses;
1084 }
1085
1086
1087 static void processModule ( Module m )
1088 {
1089    Cell  tree;
1090    ConId modNm;
1091    List  topEnts;
1092    List  tes;
1093    Cell  te;
1094    Cell  te2;
1095
1096    tyconDefns     = NIL;
1097    typeInDefns    = NIL;
1098    valDefns       = NIL;
1099    classDefns     = NIL;
1100    instDefns      = NIL;
1101    selDefns       = NIL;
1102    genDefns       = NIL;
1103    unqualImports  = NIL;
1104    foreignImports = NIL;
1105    foreignExports = NIL;
1106    defaultDefns   = NIL;
1107    defaultLine    = 0;
1108    inputExpr      = NIL;
1109
1110    setCurrentFile(m);
1111    startModule(m);
1112    tree = unap(M_MODULE,module(m).tree);
1113    modNm = zfst3(tree);
1114
1115    if (textOf(modNm) != module(m).text) {
1116       ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"",
1117                 textToStr(textOf(modNm)),
1118                 textToStr(module(m).text),
1119                 textToStr(module(m).srcExt)
1120       EEND;
1121    }
1122
1123    setExportList(zsnd3(tree));
1124    topEnts = zthd3(tree);
1125
1126    for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1127       te  = hd(tes);
1128       assert(isGenPair(te));
1129       te2 = snd(te);
1130       switch(whatIs(te)) {
1131          case M_IMPORT_Q:
1132             addQualImport(zfst(te2),zsnd(te2));
1133             break;
1134          case M_IMPORT_UNQ:
1135             addUnqualImport(zfst(te2),zsnd(te2));
1136             break;
1137          case M_TYCON:
1138             tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1139             break;
1140          case M_CLASS:
1141             classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1142             break;
1143          case M_INST:
1144             instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2));
1145             break;
1146          case M_DEFAULT:
1147             defaultDefn(intOf(zfst(te2)),zsnd(te2));
1148             break;
1149          case M_FOREIGN_IM:
1150             foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1151                           zsel45(te2),zsel55(te2));
1152             break;
1153          case M_FOREIGN_EX:
1154             foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1155                           zsel45(te2),zsel55(te2));
1156          case M_VALUE:
1157             valDefns = cons(te2,valDefns);
1158             break;
1159          default:
1160             internal("processModule");
1161       }
1162    }
1163    checkDefns(m);
1164    typeCheckDefns();
1165    compileDefns();
1166 }
1167
1168
1169 static Module parseModuleOrInterface ( ConId mc, Cell modeRequest )
1170 {
1171    /* Allocate a module-table entry. */
1172    /* Parse the entity and fill in the .tree and .uses entries. */
1173    String path;
1174    String sExt;
1175    Bool sAvail;  Time sTime;  Long sSize;
1176    Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1177    Bool ok;
1178    Bool useSource;
1179    char name[10000];
1180
1181    Text   mt  = textOf(mc);
1182    Module mod = findModule ( mt );
1183
1184    /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1185                 textToStr(mt),mod); */
1186    if (nonNull(mod) && !module(mod).fake)
1187       internal("parseModuleOrInterface");
1188    if (nonNull(mod))
1189       module(mod).fake = FALSE;
1190
1191    if (isNull(mod))
1192       mod = newModule(mt);
1193
1194    /* This call malloc-ates path; we should deallocate it. */
1195    ok = findFilesForModule (
1196            textToStr(module(mod).text),
1197            &path,
1198            &sExt,
1199            &sAvail,  &sTime,  &sSize,
1200            &oiAvail, &oiTime, &oSize, &iSize
1201         );
1202
1203    if (!ok) goto cant_find;
1204    if (!sAvail && !oiAvail) goto cant_find;
1205
1206    /* Find out whether to use source or object. */
1207    switch (modeRequest) {
1208       case FM_SOURCE:
1209          if (!sAvail) goto cant_find;
1210          useSource = TRUE;
1211          break;
1212       case FM_OBJECT:
1213          if (!oiAvail) goto cant_find;
1214          useSource = FALSE;
1215          break;
1216       case FM_EITHER:
1217          if ( sAvail && !oiAvail) { useSource = TRUE; break; }
1218          if (!sAvail &&  oiAvail) { useSource = FALSE; break; }
1219          useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE;
1220          break;
1221       default:
1222          internal("parseModuleOrInterface");
1223    }
1224
1225    /* Actually do the parsing. */
1226    if (useSource) {
1227       module(mod).srcExt = findText(sExt);
1228       setCurrentFile(mod);
1229       strcpy(name, path);
1230       strcat(name, textToStr(mt));
1231       strcat(name, sExt);
1232       module(mod).tree      = parseModule(name,sSize);
1233       module(mod).uses      = getModuleImports(module(mod).tree);
1234       module(mod).mode      = FM_SOURCE;
1235       module(mod).lastStamp = sTime;
1236    } else {
1237       module(mod).srcExt = findText(HI_ENDING);
1238       setCurrentFile(mod);
1239       strcpy(name, path);
1240       strcat(name, textToStr(mt));
1241       strcat(name, DLL_ENDING);
1242       module(mod).objName = findText(name);
1243       module(mod).objSize = oSize;
1244       strcpy(name, path);
1245       strcat(name, textToStr(mt));
1246       strcat(name, ".u_hi");
1247       module(mod).tree      = parseInterface(name,iSize);
1248       module(mod).uses      = getInterfaceImports(module(mod).tree);
1249       module(mod).mode      = FM_OBJECT;
1250       module(mod).lastStamp = oiTime;
1251    }
1252
1253    if (path) free(path);
1254    return mod;
1255
1256   cant_find:
1257    if (path) free(path);
1258    clearCurrentFile();
1259    ERRMSG(0)
1260       "Can't find %s for module \"%s\"",
1261       modeToString(modeRequest), textToStr(mt)
1262    EEND;
1263 }
1264
1265
1266 static void tryLoadGroup ( Cell grp )
1267 {
1268    Module m;
1269    List   t;
1270    switch (whatIs(grp)) {
1271       case GRP_NONREC:
1272          m = findModule(textOf(snd(grp)));
1273          assert(nonNull(m));
1274          if (module(m).mode == FM_SOURCE) {
1275             processModule ( m );
1276             module(m).tree = NIL;
1277          } else {
1278             processInterfaces ( singleton(snd(grp)) );
1279             m = findModule(textOf(snd(grp)));
1280             assert(nonNull(m));
1281             module(m).tree = NIL;
1282          }
1283          break;
1284       case GRP_REC:
1285          for (t = snd(grp); nonNull(t); t=tl(t)) {
1286             m = findModule(textOf(hd(t)));
1287             assert(nonNull(m));
1288             if (module(m).mode == FM_SOURCE) {
1289                ERRMSG(0) "Source module \"%s\" imports itself recursively",
1290                          textToStr(textOf(hd(t)))
1291                EEND;
1292             }
1293          }
1294          processInterfaces ( snd(grp) );
1295          for (t = snd(grp); nonNull(t); t=tl(t)) {
1296             m = findModule(textOf(hd(t)));
1297             assert(nonNull(m));
1298             module(m).tree = NIL;
1299          }
1300          break;
1301       default:
1302          internal("tryLoadGroup");
1303    }
1304 }
1305
1306
1307 static void fallBackToPrelModules ( void )
1308 {
1309    Module m;
1310    for (m = MODULE_BASE_ADDR;
1311         m < MODULE_BASE_ADDR+tabModuleSz; m++)
1312       if (module(m).inUse
1313           && !varIsMember(module(m).text, prelModules))
1314          nukeModule(m);
1315 }
1316
1317
1318 /* This function catches exceptions in most of the system.
1319    So it's only ok for procedures called from this one
1320    to do EENDs (ie, write error messages).  Others should use
1321    EEND_NO_LONGJMP.
1322 */
1323 static void achieveTargetModules ( Bool loadingThePrelude )
1324 {
1325    volatile List   ood;
1326    volatile List   modgList;
1327    volatile List   t;
1328    volatile Module mod;
1329    volatile Bool   ok;
1330
1331    String path = NULL;
1332    String sExt = NULL;
1333    Bool sAvail;  Time sTime;  Long sSize;
1334    Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1335
1336    volatile Time oisTime;
1337    volatile Bool out_of_date;
1338    volatile List ood_new;
1339    volatile List us;
1340    volatile List modgList_new;
1341    volatile List parsedButNotLoaded;
1342    volatile List toChase;
1343    volatile List trans_cl;
1344    volatile List trans_cl_new;
1345    volatile List u;
1346    volatile List mg;
1347    volatile List mg2;
1348    volatile Cell grp;
1349    volatile List badMods;
1350
1351    setBreakAction ( HugsIgnoreBreak );
1352
1353    /* First, examine timestamps to find out which modules are
1354       out of date with respect to the source/interface/object files.
1355    */
1356    ood      = NIL;
1357    modgList = listFromMG();
1358
1359    for (t = modgList; nonNull(t); t=tl(t)) {
1360
1361       if (varIsMember(textOf(hd(t)),prelModules))
1362          continue;
1363
1364       mod = findModule(textOf(hd(t)));
1365       if (isNull(mod)) internal("achieveTargetSet(1)");
1366
1367       /* In standalone mode, only succeeds for source modules. */
1368       ok = findFilesForModule (
1369               textToStr(module(mod).text),
1370               &path,
1371               &sExt,
1372               &sAvail,  &sTime,  &sSize,
1373               &oiAvail, &oiTime, &oSize, &iSize
1374            );
1375
1376       if (!combined && !sAvail) ok = FALSE;
1377       if (!ok) {
1378          fallBackToPrelModules();
1379          ERRMSG(0)
1380             "Can't find source or object+interface for module \"%s\"",
1381             textToStr(module(mod).text)
1382          EEND_NO_LONGJMP;
1383          if (path) free(path);
1384          return;
1385       }
1386
1387       if (sAvail && oiAvail) {
1388          oisTime = whicheverIsLater(sTime,oiTime);
1389       }
1390       else if (sAvail && !oiAvail) {
1391          oisTime = sTime;
1392       }
1393       else if (!sAvail && oiAvail) {
1394          oisTime = oiTime;
1395       }
1396       else {
1397          internal("achieveTargetSet(2)");
1398       }
1399
1400       out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1401       if (out_of_date) {
1402          assert(!varIsMember(textOf(hd(t)),ood));
1403          ood = cons(hd(t),ood);
1404       }
1405
1406       if (path) { free(path); path = NULL; };
1407    }
1408
1409    /* Second, form a simplistic transitive closure of the out-of-date
1410       modules: a module is out of date if it imports an out-of-date
1411       module.
1412    */
1413    while (1) {
1414       ood_new = NIL;
1415       for (t = modgList; nonNull(t); t=tl(t)) {
1416          mod = findModule(textOf(hd(t)));
1417          assert(nonNull(mod));
1418          for (us = module(mod).uses; nonNull(us); us=tl(us))
1419             if (varIsMember(textOf(hd(us)),ood))
1420                break;
1421          if (nonNull(us)) {
1422             if (varIsMember(textOf(hd(t)),prelModules))
1423                Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1424                         textToStr(textOf(hd(t))) );
1425             else
1426                if (!varIsMember(textOf(hd(t)),ood_new) &&
1427                    !varIsMember(textOf(hd(t)),ood))
1428                   ood_new = cons(hd(t),ood_new);
1429          }
1430       }
1431       if (isNull(ood_new)) break;
1432       ood = appendOnto(ood_new,ood);
1433    }
1434
1435    /* Now ood holds the entire set of modules which are out-of-date.
1436       Throw them out of the system, yielding a "reduced system",
1437       in which the remaining modules are in-date.
1438    */
1439    for (t = ood; nonNull(t); t=tl(t)) {
1440       mod = findModule(textOf(hd(t)));
1441       assert(nonNull(mod));
1442       nukeModule(mod);
1443    }
1444    modgList_new = NIL;
1445    for (t = modgList; nonNull(t); t=tl(t))
1446       if (!varIsMember(textOf(hd(t)),ood))
1447          modgList_new = cons(hd(t),modgList_new);
1448    modgList = modgList_new;
1449
1450    /* Update the module group list to reflect the reduced system.
1451       We do this so that if the following parsing phases fail, we can
1452       safely fall back to the reduced system.
1453    */
1454    mgFromList ( modgList );
1455
1456    /* Parse modules/interfaces, collecting parse trees and chasing
1457       imports, starting from the target set.
1458    */
1459    toChase = dupList(targetModules);
1460    for (t = toChase; nonNull(t); t=tl(t)) {
1461       Cell mode = (!combined)
1462                   ? FM_SOURCE
1463                   : ( (loadingThePrelude && combined)
1464                       ? FM_OBJECT
1465                       : FM_EITHER );
1466       hd(t) = zpair(hd(t), mode);
1467    }
1468
1469    /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */
1470
1471    parsedButNotLoaded = NIL;
1472
1473
1474    while (nonNull(toChase)) {
1475       ConId mc   = zfst(hd(toChase));
1476       Cell  mode = zsnd(hd(toChase));
1477       toChase    = tl(toChase);
1478       if (varIsMember(textOf(mc),modgList)
1479           || varIsMember(textOf(mc),parsedButNotLoaded)) {
1480          /* either exists fully, or is at least parsed */
1481          mod = findModule(textOf(mc));
1482          assert(nonNull(mod));
1483          if (!compatibleNewMode(mode,module(mod).mode)) {
1484             clearCurrentFile();
1485             ERRMSG(0)
1486                "module %s: %s required, but %s is more recent",
1487                textToStr(textOf(mc)), modeToString(mode),
1488                modeToString(module(mod).mode)
1489             EEND_NO_LONGJMP;
1490             goto parseException;
1491          }
1492       } else {
1493
1494          setBreakAction ( HugsLongjmpOnBreak );
1495          if (setjmp(catch_error)==0) {
1496             /* try this; it may throw an exception */
1497             mod = parseModuleOrInterface ( mc, mode );
1498          } else {
1499             /* here's the exception handler, if parsing fails */
1500             /* A parse error (or similar).  Clean up and abort. */
1501            parseException:
1502             setBreakAction ( HugsIgnoreBreak );
1503             mod = findModule(textOf(mc));
1504             if (nonNull(mod)) nukeModule(mod);
1505             for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1506                mod = findModule(textOf(hd(t)));
1507                assert(nonNull(mod));
1508                if (nonNull(mod)) nukeModule(mod);
1509             }
1510             return;
1511             /* end of the exception handler */
1512          }
1513          setBreakAction ( HugsIgnoreBreak );
1514
1515          parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1516          for (t = module(mod).uses; nonNull(t); t=tl(t))
1517             toChase = cons(
1518                         zpair( hd(t), childMode(mode,module(mod).mode) ),
1519                         toChase);
1520       }
1521    }
1522
1523    modgList = dupOnto(parsedButNotLoaded, modgList);
1524
1525    /* We successfully parsed all modules reachable from the target
1526       set which were not part of the reduced system.  However, there
1527       may be modules in the reduced system which are not reachable from
1528       the target set.  We detect these now by building the transitive
1529       closure of the target set, and nuking modules in the reduced
1530       system which are not part of that closure.
1531    */
1532    trans_cl = dupList(targetModules);
1533    while (1) {
1534       trans_cl_new = NIL;
1535       for (t = trans_cl; nonNull(t); t=tl(t)) {
1536          mod = findModule(textOf(hd(t)));
1537          assert(nonNull(mod));
1538          for (u = module(mod).uses; nonNull(u); u=tl(u))
1539             if (!varIsMember(textOf(hd(u)),trans_cl)
1540                 && !varIsMember(textOf(hd(u)),trans_cl_new)
1541                 && !varIsMember(textOf(hd(u)),prelModules))
1542                trans_cl_new = cons(hd(u),trans_cl_new);
1543       }
1544       if (isNull(trans_cl_new)) break;
1545       trans_cl = appendOnto(trans_cl_new,trans_cl);
1546    }
1547    modgList_new = NIL;
1548    for (t = modgList; nonNull(t); t=tl(t)) {
1549       if (varIsMember(textOf(hd(t)),trans_cl)) {
1550          modgList_new = cons(hd(t),modgList_new);
1551       } else {
1552          mod = findModule(textOf(hd(t)));
1553          assert(nonNull(mod));
1554          nukeModule(mod);
1555       }
1556    }
1557    modgList = modgList_new;
1558
1559    /* Now, the module symbol tables hold exactly the set of
1560       modules reachable from the target set, and modgList holds
1561       their names.   Calculate the scc-ified module graph,
1562       since we need that to guide the next stage, that of
1563       Actually Loading the modules.
1564
1565       If no errors occur, moduleGraph will reflect the final graph
1566       loaded.  If an error occurs loading a group, we nuke
1567       that group, truncate the moduleGraph just prior to that
1568       group, and exit.  That leaves the system having successfully
1569       loaded all groups prior to the one which failed.
1570    */
1571    mgFromList ( modgList );
1572
1573    for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1574       grp = hd(mg);
1575
1576       if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1577                        parsedButNotLoaded)) continue;
1578
1579       setBreakAction ( HugsLongjmpOnBreak );
1580       if (setjmp(catch_error)==0) {
1581          /* try this; it may throw an exception */
1582          tryLoadGroup(grp);
1583       } else {
1584          /* here's the exception handler, if static/typecheck etc fails */
1585          /* nuke the entire rest (ie, the unloaded part)
1586             of the module graph */
1587          setBreakAction ( HugsIgnoreBreak );
1588          badMods = listFromSpecifiedMG ( mg );
1589          for (t = badMods; nonNull(t); t=tl(t)) {
1590             mod = findModule(textOf(hd(t)));
1591             if (nonNull(mod)) nukeModule(mod);
1592          }
1593          /* truncate the module graph just prior to this group. */
1594          mg2 = NIL;
1595          mg = moduleGraph;
1596          while (TRUE) {
1597             if (isNull(mg)) break;
1598             if (hd(mg) == grp) break;
1599             mg2 = cons ( hd(mg), mg2 );
1600             mg = tl(mg);
1601          }
1602          moduleGraph = reverse(mg2);
1603          return;
1604          /* end of the exception handler */
1605       }
1606       setBreakAction ( HugsIgnoreBreak );
1607    }
1608
1609    /* Err .. I think that's it.  If we get here, we've successfully
1610       achieved the target set.  Phew!
1611    */
1612    setBreakAction ( HugsIgnoreBreak );
1613 }
1614
1615
1616 static Bool loadThePrelude ( void )
1617 {
1618    Bool ok;
1619    ConId conPrelude;
1620    ConId conPrelHugs;
1621    moduleGraph = prelModules = NIL;
1622
1623    if (combined) {
1624       conPrelude    = mkCon(findText("Prelude"));
1625       conPrelHugs   = mkCon(findText("PrelHugs"));
1626       targetModules = doubleton(conPrelude,conPrelHugs);
1627       achieveTargetModules(TRUE);
1628       ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1629    } else {
1630       conPrelude    = mkCon(findText("Prelude"));
1631       targetModules = singleton(conPrelude);
1632       achieveTargetModules(TRUE);
1633       ok = elemMG(conPrelude);
1634    }
1635
1636    if (ok) prelModules = listFromMG();
1637    return ok;
1638 }
1639
1640
1641 /* Refresh the current target modules, and attempt to set the
1642    current module to what it was before (ie currentModule):
1643      if currentModule_failed is different from currentModule,
1644         use that instead
1645      if nextCurrMod is non null, try to set it to that instead
1646      if the one we're after insn't available, select a target
1647        from the end of the module group list.
1648 */
1649 static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
1650 {
1651    List t;
1652    ConId tryFor;
1653
1654    /* Remember what the old current module was. */
1655    tryFor = mkCon(module(currentModule).text);
1656
1657    /* Do the Real Work. */
1658    achieveTargetModules(FALSE);
1659
1660    /* Remember if the current module was invalidated by this
1661       refresh, so later refreshes can attempt to reload it. */
1662    if (!elemMG(tryFor))
1663       currentModule_failed = tryFor;
1664
1665    /* If a previous refresh failed to get an old current module,
1666       try for that instead. */
1667    if (nonNull(currentModule_failed)
1668        && textOf(currentModule_failed) != textOf(tryFor)
1669        && elemMG(currentModule_failed))
1670       tryFor = currentModule_failed;
1671    /* If our caller specified a new current module, that overrides
1672       all historical settings. */
1673    if (nonNull(nextCurrMod))
1674       tryFor = nextCurrMod;
1675    /* Finally, if we can't actually get hold of whatever it was we
1676       were after, select something which is possible. */
1677    if (!elemMG(tryFor))
1678       tryFor = selectLatestMG();
1679
1680    /* combined mode kludge, to get Prelude rather than PrelHugs */
1681    if (combined && textOf(tryFor)==findText("PrelHugs"))
1682       tryFor = mkCon(findText("Prelude"));
1683
1684    if (cleanAfter) {
1685       /* delete any targetModules which didn't actually get loaded  */
1686       t = targetModules;
1687       targetModules = NIL;
1688       for (; nonNull(t); t=tl(t))
1689          if (elemMG(hd(t)))
1690             targetModules = cons(hd(t),targetModules);
1691    }
1692
1693    setCurrModule ( findModule(textOf(tryFor)) );
1694    Printf("Hugs session for:\n");
1695    ppMG();
1696 }
1697
1698
1699 static void addActions ( List extraModules /* :: [CONID] */ )
1700 {
1701    List t;
1702    for (t = extraModules; nonNull(t); t=tl(t)) {
1703       ConId extra = hd(t);
1704       if (!varIsMember(textOf(extra),targetModules))
1705          targetModules = cons(extra,targetModules);
1706    }
1707    refreshActions ( isNull(extraModules)
1708                        ? NIL
1709                        : hd(reverse(extraModules)),
1710                     TRUE
1711                   );
1712 }
1713
1714
1715 static void loadActions ( List loadModules /* :: [CONID] */ )
1716 {
1717    List t;
1718    targetModules = dupList ( prelModules );
1719
1720    for (t = loadModules; nonNull(t); t=tl(t)) {
1721       ConId load = hd(t);
1722       if (!varIsMember(textOf(load),targetModules))
1723          targetModules = cons(load,targetModules);
1724    }
1725    refreshActions ( isNull(loadModules)
1726                        ? NIL
1727                        : hd(reverse(loadModules)),
1728                     TRUE
1729                   );
1730 }
1731
1732
1733 /* --------------------------------------------------------------------------
1734  * Access to external editor:
1735  * ------------------------------------------------------------------------*/
1736
1737 /* ToDo: All this editor stuff needs fixing. */
1738
1739 static Void local editor() {            /* interpreter-editor interface    */
1740 #if 0
1741     String newFile  = readFilename();
1742     if (newFile) {
1743         setLastEdit(newFile,0);
1744         if (readFilename()) {
1745             ERRMSG(0) "Multiple filenames not permitted"
1746             EEND;
1747         }
1748     }
1749     runEditor();
1750 #endif
1751 }
1752
1753 static Void local find() {              /* edit file containing definition */
1754 #if 0
1755 ToDo: Fix!
1756     String nm = readFilename();         /* of specified name               */
1757     if (!nm) {
1758         ERRMSG(0) "No name specified"
1759         EEND;
1760     }
1761     else if (readFilename()) {
1762         ERRMSG(0) "Multiple names not permitted"
1763         EEND;
1764     }
1765     else {
1766         Text t;
1767         Cell c;
1768         setCurrModule(findEvalModule());
1769         startNewScript(0);
1770         if (nonNull(c=findTycon(t=findText(nm)))) {
1771             if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1772                 readScripts(N_PRELUDE_SCRIPTS);
1773             }
1774         } else if (nonNull(c=findName(t))) {
1775             if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1776                 readScripts(N_PRELUDE_SCRIPTS);
1777             }
1778         } else {
1779             ERRMSG(0) "No current definition for name \"%s\"", nm
1780             EEND;
1781         }
1782     }
1783 #endif
1784 }
1785
1786 static Void local runEditor() {         /* run editor on script lastEdit   */
1787 #if 0
1788     if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine              */
1789         readScripts(N_PRELUDE_SCRIPTS);
1790 #endif
1791 }
1792
1793 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1794 String fname;
1795 Int    line; {
1796 #if 0
1797     if (lastEdit)
1798         free(lastEdit);
1799     lastEdit = strCopy(fname);
1800     lastEdLine = line;
1801 #endif
1802 }
1803
1804 /* --------------------------------------------------------------------------
1805  * Read and evaluate an expression:
1806  * ------------------------------------------------------------------------*/
1807
1808 static Void setModule ( void ) {
1809                               /*set module in which to evaluate expressions*/
1810    Module m;
1811    ConId  mc = NIL;
1812    String s  = readFilename();
1813    if (!s) {
1814       mc = selectLatestMG();
1815       if (combined && textOf(mc)==findText("PrelHugs"))
1816          mc = mkCon(findText("Prelude"));
1817       m = findModule(textOf(mc));
1818       assert(nonNull(m));
1819    } else {
1820       m = findModule(findText(s));
1821       if (isNull(m)) {
1822          ERRMSG(0) "Cannot find module \"%s\"", s
1823          EEND_NO_LONGJMP;
1824          return;
1825       }
1826    }
1827    setCurrModule(m);
1828 }
1829
1830 static Module allocEvalModule ( void )
1831 {
1832    Module evalMod = newModule( findText("_Eval_Module_") );
1833    module(evalMod).names   = module(currentModule).names;
1834    module(evalMod).tycons  = module(currentModule).tycons;
1835    module(evalMod).classes = module(currentModule).classes;
1836    module(evalMod).qualImports
1837      = singleton(pair(mkCon(textPrelude),modulePrelude));
1838    return evalMod;
1839 }
1840
1841 static Void local evaluator() {        /* evaluate expr and print value    */
1842     volatile Type   type;
1843     volatile Type   bd;
1844     volatile Kinds  ks      = NIL;
1845     volatile Module evalMod = allocEvalModule();
1846     volatile Module currMod = currentModule;
1847     setCurrModule(evalMod);
1848     currentFile = NULL;
1849
1850     defaultDefns = combined ? stdDefaults : evalDefaults;
1851
1852     setBreakAction ( HugsLongjmpOnBreak );
1853     if (setjmp(catch_error)==0) {
1854        /* try this */
1855        parseExp();
1856        checkExp();
1857        type = typeCheckExp(TRUE);
1858     } else {
1859        /* if an exception happens, we arrive here */
1860        setBreakAction ( HugsIgnoreBreak );
1861        goto cleanup_and_return;
1862     }
1863
1864     setBreakAction ( HugsIgnoreBreak );
1865     if (isPolyType(type)) {
1866         ks = polySigOf(type);
1867         bd = monotypeOf(type);
1868     }
1869     else
1870         bd = type;
1871
1872     if (whatIs(bd)==QUAL) {
1873         printing = FALSE;
1874        clearCurrentFile();
1875        ERRMSG(0) "Unresolved overloading" ETHEN
1876        ERRTEXT   "\n*** Type       : "    ETHEN ERRTYPE(type);
1877        ERRTEXT   "\n*** Expression : "    ETHEN ERREXPR(inputExpr);
1878        ERRTEXT   "\n"
1879        EEND_NO_LONGJMP;
1880        goto cleanup_and_return;
1881     }
1882
1883 #if 1
1884     printing      = TRUE;
1885     numEnters     = 0;
1886     if (isProgType(ks,bd)) {
1887         inputExpr = ap(nameRunIO_toplevel,inputExpr);
1888         evalExp();
1889         Putchar('\n');
1890     } else {
1891         Cell d = provePred(ks,NIL,ap(classShow,bd));
1892         if (isNull(d)) {
1893            clearCurrentFile();
1894            printing = FALSE;
1895            ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1896            ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
1897            ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
1898            ERRTEXT   "\n"
1899            EEND_NO_LONGJMP;
1900            goto cleanup_and_return;
1901         }
1902         inputExpr = ap2(nameShow,           d,inputExpr);
1903         inputExpr = ap (namePutStr,         inputExpr);
1904         inputExpr = ap (nameRunIO_toplevel, inputExpr);
1905
1906         evalExp(); printf("\n");
1907         if (addType) {
1908             printf(" :: ");
1909             printType(stdout,type);
1910             Putchar('\n');
1911         }
1912     }
1913
1914 #else
1915
1916    printf ( "result type is " );
1917    printType ( stdout, type );
1918    printf ( "\n" );
1919    evalExp();
1920    printf ( "\n" );
1921
1922 #endif
1923
1924   cleanup_and_return:
1925    setBreakAction ( HugsIgnoreBreak );
1926    nukeModule(evalMod);
1927    setCurrModule(currMod);
1928    setCurrentFile(currMod);
1929    stopAnyPrinting();
1930 }
1931
1932
1933
1934 /* --------------------------------------------------------------------------
1935  * Print type of input expression:
1936  * ------------------------------------------------------------------------*/
1937
1938 static Void showtype ( void ) {        /* print type of expression (if any)*/
1939
1940     volatile Cell   type;
1941     volatile Module evalMod = allocEvalModule();
1942     volatile Module currMod = currentModule;
1943     setCurrModule(evalMod);
1944
1945     if (setjmp(catch_error)==0) {
1946        /* try this */
1947        parseExp();
1948        checkExp();
1949        defaultDefns = evalDefaults;
1950        type = typeCheckExp(FALSE);
1951        printExp(stdout,inputExpr);
1952        Printf(" :: ");
1953        printType(stdout,type);
1954        Putchar('\n');
1955     } else {
1956        /* if an exception happens, we arrive here */
1957     }
1958
1959     nukeModule(evalMod);
1960     setCurrModule(currMod);
1961 }
1962
1963
1964 static Void local browseit(mod,t,all)
1965 Module mod;
1966 String t;
1967 Bool all; {
1968     if (nonNull(mod)) {
1969         Cell cs;
1970         if (nonNull(t))
1971             Printf("module %s where\n",textToStr(module(mod).text));
1972         for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1973             Name nm = hd(cs);
1974             /* only look at things defined in this module,
1975                unless `all' flag is set */
1976             if (all || name(nm).mod == mod) {
1977                 /* unwanted artifacts, like lambda lifted values,
1978                    are in the list of names, but have no types */
1979                 if (nonNull(name(nm).type)) {
1980                     printExp(stdout,nm);
1981                     Printf(" :: ");
1982                     printType(stdout,name(nm).type);
1983                     if (isCfun(nm)) {
1984                         Printf("  -- data constructor");
1985                     } else if (isMfun(nm)) {
1986                         Printf("  -- class member");
1987                     } else if (isSfun(nm)) {
1988                         Printf("  -- selector function");
1989                     }
1990                     Printf("\n");
1991                 }
1992             }
1993         }
1994     } else {
1995       if (isNull(mod)) {
1996         Printf("Unknown module %s\n",t);
1997       }
1998     }
1999 }
2000
2001 static Void local browse() {            /* browse modules                  */
2002     Int    count = 0;                   /* or give menu of commands        */
2003     String s;
2004     Bool all = FALSE;
2005
2006     for (; (s=readFilename())!=0; count++)
2007         if (strcmp(s,"all") == 0) {
2008             all = TRUE;
2009             --count;
2010         } else
2011             browseit(findModule(findText(s)),s,all);
2012     if (count == 0) {
2013         browseit(currentModule,NULL,all);
2014     }
2015 }
2016
2017 #if EXPLAIN_INSTANCE_RESOLUTION
2018 static Void local xplain() {         /* print type of expression (if any)*/
2019     Cell d;
2020     Bool sir = showInstRes;
2021
2022     setCurrModule(findEvalModule());
2023     startNewScript(0);                 /* Enables recovery of storage      */
2024                                        /* allocated during evaluation      */
2025     parseContext();
2026     checkContext();
2027     showInstRes = TRUE;
2028     d = provePred(NIL,NIL,hd(inputContext));
2029     if (isNull(d)) {
2030         fprintf(stdout, "not Sat\n");
2031     } else {
2032         fprintf(stdout, "Sat\n");
2033     }
2034     showInstRes = sir;
2035 }
2036 #endif
2037
2038 /* --------------------------------------------------------------------------
2039  * Enhanced help system:  print current list of scripts or give information
2040  * about an object.
2041  * ------------------------------------------------------------------------*/
2042
2043 static String local objToStr(m,c)
2044 Module m;
2045 Cell   c; {
2046 #if 1 || DISPLAY_QUANTIFIERS
2047     static char newVar[60];
2048     switch (whatIs(c)) {
2049         case NAME  : if (m == name(c).mod) {
2050                          sprintf(newVar,"%s", textToStr(name(c).text));
2051                      } else {
2052                          sprintf(newVar,"%s.%s",
2053                                         textToStr(module(name(c).mod).text),
2054                                         textToStr(name(c).text));
2055                      }
2056                      break;
2057
2058         case TYCON : if (m == tycon(c).mod) {
2059                          sprintf(newVar,"%s", textToStr(tycon(c).text));
2060                      } else {
2061                          sprintf(newVar,"%s.%s",
2062                                         textToStr(module(tycon(c).mod).text),
2063                                         textToStr(tycon(c).text));
2064                      }
2065                      break;
2066
2067         case CLASS : if (m == cclass(c).mod) {
2068                          sprintf(newVar,"%s", textToStr(cclass(c).text));
2069                      } else {
2070                          sprintf(newVar,"%s.%s",
2071                                         textToStr(module(cclass(c).mod).text),
2072                                         textToStr(cclass(c).text));
2073                      }
2074                      break;
2075
2076         default    : internal("objToStr");
2077     }
2078     return newVar;
2079 #else
2080     static char newVar[33];
2081     switch (whatIs(c)) {
2082         case NAME  : sprintf(newVar,"%s", textToStr(name(c).text));
2083                      break;
2084
2085         case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
2086                      break;
2087
2088         case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
2089                      break;
2090
2091         default    : internal("objToStr");
2092     }
2093     return newVar;
2094 #endif
2095 }
2096
2097 extern Name nameHw;
2098
2099 static Void dumpStg ( void )
2100 {
2101    String s;
2102    Int i;
2103 #if 0
2104    Whats this for?
2105    setCurrModule(findEvalModule());
2106    startNewScript(0);
2107 #endif
2108    s = readFilename();
2109
2110    /* request to locate a symbol by name */
2111    if (s && (*s == '?')) {
2112       Text t = findText(s+1);
2113       locateSymbolByName(t);
2114       return;
2115    }
2116
2117    /* request to dump a bit of the heap */
2118    if (s && (*s == '-' || isdigit(*s))) {
2119       int i = atoi(s);
2120       print(i,100);
2121       printf("\n");
2122       return;
2123    }
2124
2125    /* request to dump a symbol table entry */
2126    if (!s
2127        || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
2128        || !isdigit(s[1])) {
2129       fprintf(stderr, ":d -- bad request `%s'\n", s );
2130       return;
2131    }
2132    i = atoi(s+1);
2133    switch (*s) {
2134       case 't': dumpTycon(i); break;
2135       case 'n': dumpName(i); break;
2136       case 'c': dumpClass(i); break;
2137       case 'i': dumpInst(i); break;
2138       default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
2139    }
2140 }
2141
2142
2143 #if 0
2144 static Void local dumpStg( void ) {       /* print STG stuff                 */
2145     String s;
2146     Text   t;
2147     Name   n;
2148     Int    i;
2149     Cell   v;                           /* really StgVar */
2150     setCurrModule(findEvalModule());
2151     startNewScript(0);
2152     for (; (s=readFilename())!=0;) {
2153         t = findText(s);
2154         v = n = NIL;
2155         /* find the name while ignoring module scopes */
2156         for (i=NAMEMIN; i<nameHw; i++)
2157            if (name(i).text == t) n = i;
2158
2159         /* perhaps it's an "idNNNNNN" thing? */
2160         if (isNull(n) &&
2161             strlen(s) >= 3 &&
2162             s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2163            v = 0;
2164            i = 2;
2165            while (isdigit(s[i])) {
2166               v = v * 10 + (s[i]-'0');
2167               i++;
2168            }
2169            v = -v;
2170            n = nameFromStgVar(v);
2171         }
2172
2173         if (isNull(n) && whatIs(v)==STGVAR) {
2174            Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2175            printStg(stderr, v );
2176         } else
2177         if (isNull(n)) {
2178            Printf ( "Unknown reference `%s'\n", s );
2179         } else
2180         if (!isName(n)) {
2181            Printf ( "Not a Name: `%s'\n", s );
2182         } else
2183         if (isNull(name(n).stgVar)) {
2184            Printf ( "Doesn't have a STG tree: %s\n", s );
2185         } else {
2186            Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2187            printStg(stderr, name(n).stgVar);
2188         }
2189     }
2190 }
2191 #endif
2192
2193 static Void local info() {              /* describe objects                */
2194     Int    count = 0;                   /* or give menu of commands        */
2195     String s;
2196
2197     for (; (s=readFilename())!=0; count++) {
2198         describe(findText(s));
2199     }
2200     if (count == 0) {
2201        /* whatScripts(); */
2202     }
2203 }
2204
2205
2206 static Void local describe(t)           /* describe an object              */
2207 Text t; {
2208     Tycon  tc  = findTycon(t);
2209     Class  cl  = findClass(t);
2210     Name   nm  = findName(t);
2211
2212     if (nonNull(tc)) {                  /* as a type constructor           */
2213         Type t = tc;
2214         Int  i;
2215         Inst in;
2216         for (i=0; i<tycon(tc).arity; ++i) {
2217             t = ap(t,mkOffset(i));
2218         }
2219         Printf("-- type constructor");
2220         if (kindExpert) {
2221             Printf(" with kind ");
2222             printKind(stdout,tycon(tc).kind);
2223         }
2224         Putchar('\n');
2225         switch (tycon(tc).what) {
2226             case SYNONYM      : Printf("type ");
2227                                 printType(stdout,t);
2228                                 Printf(" = ");
2229                                 printType(stdout,tycon(tc).defn);
2230                                 break;
2231
2232             case NEWTYPE      :
2233             case DATATYPE     : {   List cs = tycon(tc).defn;
2234                                     if (tycon(tc).what==DATATYPE) {
2235                                         Printf("data ");
2236                                     } else {
2237                                         Printf("newtype ");
2238                                     }
2239                                     printType(stdout,t);
2240                                     Putchar('\n');
2241                                     mapProc(printSyntax,cs);
2242                                     if (hasCfun(cs)) {
2243                                         Printf("\n-- constructors:");
2244                                     }
2245                                     for (; hasCfun(cs); cs=tl(cs)) {
2246                                         Putchar('\n');
2247                                         printExp(stdout,hd(cs));
2248                                         Printf(" :: ");
2249                                         printType(stdout,name(hd(cs)).type);
2250                                     }
2251                                     if (nonNull(cs)) {
2252                                         Printf("\n-- selectors:");
2253                                     }
2254                                     for (; nonNull(cs); cs=tl(cs)) {
2255                                         Putchar('\n');
2256                                         printExp(stdout,hd(cs));
2257                                         Printf(" :: ");
2258                                         printType(stdout,name(hd(cs)).type);
2259                                     }
2260                                 }
2261                                 break;
2262
2263             case RESTRICTSYN  : Printf("type ");
2264                                 printType(stdout,t);
2265                                 Printf(" = <restricted>");
2266                                 break;
2267         }
2268         Putchar('\n');
2269         if (nonNull(in=findFirstInst(tc))) {
2270             Printf("\n-- instances:\n");
2271             do {
2272                 showInst(in);
2273                 in = findNextInst(tc,in);
2274             } while (nonNull(in));
2275         }
2276         Putchar('\n');
2277     }
2278
2279     if (nonNull(cl)) {                  /* as a class                      */
2280         List  ins = cclass(cl).instances;
2281         Kinds ks  = cclass(cl).kinds;
2282         if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2283             Printf("-- type class");
2284         } else {
2285             Printf("-- constructor class");
2286             if (kindExpert) {
2287                 Printf(" with arity ");
2288                 printKinds(stdout,ks);
2289             }
2290         }
2291         Putchar('\n');
2292         mapProc(printSyntax,cclass(cl).members);
2293         Printf("class ");
2294         if (nonNull(cclass(cl).supers)) {
2295             printContext(stdout,cclass(cl).supers);
2296             Printf(" => ");
2297         }
2298         printPred(stdout,cclass(cl).head);
2299
2300         if (nonNull(cclass(cl).fds)) {
2301             List   fds = cclass(cl).fds;
2302             String pre = " | ";
2303             for (; nonNull(fds); fds=tl(fds)) {
2304                 Printf(pre);
2305                 printFD(stdout,hd(fds));
2306                 pre = ", ";
2307             }
2308         }
2309
2310         if (nonNull(cclass(cl).members)) {
2311             List ms = cclass(cl).members;
2312             Printf(" where");
2313             do {
2314                 Type t = name(hd(ms)).type;
2315                 if (isPolyType(t)) {
2316                     t = monotypeOf(t);
2317                 }
2318                 Printf("\n  ");
2319                 printExp(stdout,hd(ms));
2320                 Printf(" :: ");
2321                 if (isNull(tl(fst(snd(t))))) {
2322                     t = snd(snd(t));
2323                 } else {
2324                     t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2325                 }
2326                 printType(stdout,t);
2327                 ms = tl(ms);
2328             } while (nonNull(ms));
2329         }
2330         Putchar('\n');
2331         if (nonNull(ins)) {
2332             Printf("\n-- instances:\n");
2333             do {
2334                 showInst(hd(ins));
2335                 ins = tl(ins);
2336             } while (nonNull(ins));
2337         }
2338         Putchar('\n');
2339     }
2340
2341     if (nonNull(nm)) {                  /* as a function/name              */
2342         printSyntax(nm);
2343         printExp(stdout,nm);
2344         Printf(" :: ");
2345         if (nonNull(name(nm).type)) {
2346             printType(stdout,name(nm).type);
2347         } else {
2348             Printf("<unknown type>");
2349         }
2350         if (isCfun(nm)) {
2351             Printf("  -- data constructor");
2352         } else if (isMfun(nm)) {
2353             Printf("  -- class member");
2354         } else if (isSfun(nm)) {
2355             Printf("  -- selector function");
2356         }
2357         Printf("\n\n");
2358     }
2359
2360
2361     if (isNull(tc) && isNull(cl) && isNull(nm)) {
2362         Printf("Unknown reference `%s'\n",textToStr(t));
2363     }
2364 }
2365
2366 static Void local printSyntax(nm)
2367 Name nm; {
2368     Syntax sy = syntaxOf(nm);
2369     Text   t  = name(nm).text;
2370     String s  = textToStr(t);
2371     if (sy != defaultSyntax(t)) {
2372         Printf("infix");
2373         switch (assocOf(sy)) {
2374             case LEFT_ASS  : Putchar('l'); break;
2375             case RIGHT_ASS : Putchar('r'); break;
2376             case NON_ASS   : break;
2377         }
2378         Printf(" %i ",precOf(sy));
2379         if (isascii((int)(*s)) && isalpha((int)(*s))) {
2380             Printf("`%s`",s);
2381         } else {
2382             Printf("%s",s);
2383         }
2384         Putchar('\n');
2385     }
2386 }
2387
2388 static Void local showInst(in)          /* Display instance decl header    */
2389 Inst in; {
2390     Printf("instance ");
2391     if (nonNull(inst(in).specifics)) {
2392         printContext(stdout,inst(in).specifics);
2393         Printf(" => ");
2394     }
2395     printPred(stdout,inst(in).head);
2396     Putchar('\n');
2397 }
2398
2399 /* --------------------------------------------------------------------------
2400  * List all names currently in scope:
2401  * ------------------------------------------------------------------------*/
2402
2403 static Void local listNames() {         /* list names matching optional pat*/
2404     String pat   = readFilename();
2405     List   names = NIL;
2406     Int    width = getTerminalWidth() - 1;
2407     Int    count = 0;
2408     Int    termPos;
2409     Module mod   = currentModule;
2410
2411     if (pat) {                          /* First gather names to list      */
2412         do {
2413             names = addNamesMatching(pat,names);
2414         } while ((pat=readFilename())!=0);
2415     } else {
2416         names = addNamesMatching((String)0,names);
2417     }
2418     if (isNull(names)) {                /* Then print them out             */
2419         clearCurrentFile();
2420         ERRMSG(0) "No names selected"
2421         EEND_NO_LONGJMP;
2422         return;
2423     }
2424     for (termPos=0; nonNull(names); names=tl(names)) {
2425         String s = objToStr(mod,hd(names));
2426         Int    l = strlen(s);
2427         if (termPos+1+l>width) {
2428             Putchar('\n');
2429             termPos = 0;
2430         } else if (termPos>0) {
2431             Putchar(' ');
2432             termPos++;
2433         }
2434         Printf("%s",s);
2435         termPos += l;
2436         count++;
2437     }
2438     Printf("\n(%d names listed)\n", count);
2439 }
2440
2441 /* --------------------------------------------------------------------------
2442  * print a prompt and read a line of input:
2443  * ------------------------------------------------------------------------*/
2444
2445 static Void local promptForInput(moduleName)
2446 String moduleName; {
2447     char promptBuffer[1000];
2448 #if 1
2449     /* This is portable but could overflow buffer */
2450     sprintf(promptBuffer,prompt,moduleName);
2451 #else
2452     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2453      * promptBuffer instead.
2454      */
2455     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2456         /* Reset prompt to a safe default to avoid an infinite loop */
2457         free(prompt);
2458         prompt = strCopy("? ");
2459         internal("Combined prompt and evaluation module name too long");
2460     }
2461 #endif
2462     if (autoMain)
2463        stringInput("main\0"); else
2464        consoleInput(promptBuffer);
2465 }
2466
2467 /* --------------------------------------------------------------------------
2468  * main read-eval-print loop, with error trapping:
2469  * ------------------------------------------------------------------------*/
2470
2471 static Void local interpreter(argc,argv)/* main interpreter loop           */
2472 Int    argc;
2473 String argv[]; {
2474
2475     List   modConIds; /* :: [CONID] */
2476     Bool   prelOK;
2477     String s;
2478
2479     setBreakAction ( HugsIgnoreBreak );
2480     modConIds = initialize(argc,argv);  /* the initial modules to load     */
2481     setBreakAction ( HugsIgnoreBreak );
2482     prelOK    = loadThePrelude();
2483
2484     if (!prelOK) {
2485        if (autoMain)
2486           fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2487        else
2488           fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2489        exit(1);
2490     }
2491
2492     if (combined) everybody(POSTPREL);
2493     loadActions(modConIds);
2494
2495     if (autoMain) {
2496        for (; nonNull(modConIds); modConIds=tl(modConIds))
2497           if (!elemMG(hd(modConIds))) {
2498              fprintf(stderr,
2499                      "hugs +Q: compilation failed -- can't run `main'\n" );
2500              exit(1);
2501           }
2502     }
2503
2504     modConIds = NIL;
2505
2506     /* initialize calls startupHaskell, which trashes our signal handlers */
2507     setBreakAction ( HugsIgnoreBreak );
2508     forHelp();
2509
2510     for (;;) {
2511         Command cmd;
2512         everybody(RESET);               /* reset to sensible initial state */
2513
2514         promptForInput(textToStr(module(currentModule).text));
2515
2516         cmd = readCommand(cmds, (Char)':', (Char)'!');
2517         switch (cmd) {
2518             case EDIT   : editor();
2519                           break;
2520             case FIND   : find();
2521                           break;
2522             case LOAD   : modConIds = NIL;
2523                 while ((s=readFilename())!=0) {
2524                           modConIds = cons(mkCon(findText(s)),modConIds);
2525
2526                 }
2527                           loadActions(modConIds);
2528                           modConIds = NIL;
2529                           break;
2530             case ALSO   : modConIds = NIL;
2531                           while ((s=readFilename())!=0)
2532                              modConIds = cons(mkCon(findText(s)),modConIds);
2533                           addActions(modConIds);
2534                           modConIds = NIL;
2535                           break;
2536             case RELOAD : refreshActions(NIL,FALSE);
2537                           break;
2538             case SETMODULE :
2539                           setModule();
2540                           break;
2541             case EVAL   : evaluator();
2542                           break;
2543             case TYPEOF : showtype();
2544                           break;
2545             case BROWSE : browse();
2546                           break;
2547 #if EXPLAIN_INSTANCE_RESOLUTION
2548             case XPLAIN : xplain();
2549                           break;
2550 #endif
2551             case NAMES  : listNames();
2552                           break;
2553             case HELP   : menu();
2554                           break;
2555             case BADCMD : guidance();
2556                           break;
2557             case SET    : set();
2558                           break;
2559             case SYSTEM : if (shellEsc(readLine()))
2560                               Printf("Warning: Shell escape terminated abnormally\n");
2561                           break;
2562             case CHGDIR : changeDir();
2563                           break;
2564             case INFO   : info();
2565                           break;
2566             case PNTVER: Printf("-- Hugs Version %s\n",
2567                                  HUGS_VERSION);
2568                           break;
2569             case DUMP   : dumpStg();
2570                           break;
2571             case QUIT   : return;
2572             case COLLECT: consGC = FALSE;
2573                           garbageCollect();
2574                           consGC = TRUE;
2575                           Printf("Garbage collection recovered %d cells\n",
2576                                  cellsRecovered);
2577                           break;
2578             case NOCMD  : break;
2579         }
2580
2581         if (autoMain) break;
2582     }
2583 }
2584
2585 /* --------------------------------------------------------------------------
2586  * Display progress towards goal:
2587  * ------------------------------------------------------------------------*/
2588
2589 static Target currTarget;
2590 static Bool   aiming = FALSE;
2591 static Int    currPos;
2592 static Int    maxPos;
2593 static Int    charCount;
2594
2595 Void setGoal(what, t)                  /* Set goal for what to be t        */
2596 String what;
2597 Target t; {
2598     if (quiet)
2599       return;
2600 #if EXPLAIN_INSTANCE_RESOLUTION
2601     if (showInstRes)
2602       return;
2603 #endif
2604     currTarget = (t?t:1);
2605     aiming     = TRUE;
2606     if (useDots) {
2607         currPos = strlen(what);
2608         maxPos  = getTerminalWidth() - 1;
2609         Printf("%s",what);
2610     }
2611     else
2612         for (charCount=0; *what; charCount++)
2613             Putchar(*what++);
2614     FlushStdout();
2615 }
2616
2617 Void soFar(t)                          /* Indicate progress towards goal   */
2618 Target t; {                            /* has now reached t                */
2619     if (quiet)
2620       return;
2621 #if EXPLAIN_INSTANCE_RESOLUTION
2622     if (showInstRes)
2623       return;
2624 #endif
2625     if (useDots) {
2626         Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2627
2628         if (newPos>maxPos)
2629             newPos = maxPos;
2630
2631         if (newPos>currPos) {
2632             do
2633                 Putchar('.');
2634             while (newPos>++currPos);
2635             FlushStdout();
2636         }
2637         FlushStdout();
2638     }
2639 }
2640
2641 Void done() {                          /* Goal has now been achieved       */
2642     if (quiet)
2643       return;
2644 #if EXPLAIN_INSTANCE_RESOLUTION
2645     if (showInstRes)
2646       return;
2647 #endif
2648     if (useDots) {
2649         while (maxPos>currPos++)
2650             Putchar('.');
2651         Putchar('\n');
2652     }
2653     else
2654         for (; charCount>0; charCount--) {
2655             Putchar('\b');
2656             Putchar(' ');
2657             Putchar('\b');
2658         }
2659     aiming = FALSE;
2660     FlushStdout();
2661 }
2662
2663 static Void local failed() {           /* Goal cannot be reached due to    */
2664     if (aiming) {                      /* errors                           */
2665         aiming = FALSE;
2666         Putchar('\n');
2667         FlushStdout();
2668     }
2669 }
2670
2671 /* --------------------------------------------------------------------------
2672  * Error handling:
2673  * ------------------------------------------------------------------------*/
2674
2675 static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
2676     if (printing) {                    /* after successful termination or  */
2677         printing = FALSE;              /* runtime error (e.g. interrupt)   */
2678         Putchar('\n');
2679         if (showStats) {
2680 #define plural(v)   v, (v==1?"":"s")
2681             Printf("(%lu enter%s)\n",plural(numEnters));
2682 #undef plural
2683         }
2684         FlushStdout();
2685         garbageCollect();
2686     }
2687 }
2688
2689 Cell errAssert(l)   /* message to use when raising asserts, etc */
2690 Int l; {
2691   Cell str;
2692   if (currentFile) {
2693     str = mkStr(findText(currentFile));
2694   } else {
2695     str = mkStr(findText(""));
2696   }
2697   return (ap2(nameTangleMessage,str,mkInt(l)));
2698 }
2699
2700 Void errHead(l)                        /* print start of error message     */
2701 Int l; {
2702     failed();                          /* failed to reach target ...       */
2703     stopAnyPrinting();
2704     FPrintf(errorStream,"ERROR");
2705
2706     if (currentFile) {
2707         FPrintf(errorStream," \"%s\"", currentFile);
2708         setLastEdit(currentFile,l);
2709         if (l) FPrintf(errorStream," (line %d)",l);
2710         currentFile = NULL;
2711     }
2712     FPrintf(errorStream,": ");
2713     FFlush(errorStream);
2714 }
2715
2716 Void errFail() {                        /* terminate error message and     */
2717     Putc('\n',errorStream);             /* produce exception to return to  */
2718     FFlush(errorStream);                /* main command loop               */
2719     longjmp(catch_error,1);
2720 }
2721
2722 Void errFail_no_longjmp() {             /* terminate error message but     */
2723     Putc('\n',errorStream);             /* don't produce an exception      */
2724     FFlush(errorStream);
2725 }
2726
2727 Void errAbort() {                       /* altern. form of error handling  */
2728     failed();                           /* used when suitable error message*/
2729     stopAnyPrinting();                  /* has already been printed        */
2730     errFail();
2731 }
2732
2733 Void internal(msg)                      /* handle internal error           */
2734 String msg; {
2735     failed();
2736     stopAnyPrinting();
2737     Printf("INTERNAL ERROR: %s\n",msg);
2738     FlushStdout();
2739 exit(9);
2740     longjmp(catch_error,1);
2741 }
2742
2743 Void fatal(msg)                         /* handle fatal error              */
2744 String msg; {
2745     FlushStdout();
2746     Printf("\nFATAL ERROR: %s\n",msg);
2747     everybody(EXIT);
2748     exit(1);
2749 }
2750
2751
2752 /* --------------------------------------------------------------------------
2753  * Read value from environment variable or registry:
2754  * ------------------------------------------------------------------------*/
2755
2756 String fromEnv(var,def)         /* return value of:                        */
2757 String var;                     /*     environment variable named by var   */
2758 String def; {                   /* or: default value given by def          */
2759     String s = getenv(var);
2760     return (s ? s : def);
2761 }
2762
2763 /* --------------------------------------------------------------------------
2764  * String manipulation routines:
2765  * ------------------------------------------------------------------------*/
2766
2767 static String local strCopy(s)         /* make malloced copy of a string   */
2768 String s; {
2769     if (s && *s) {
2770         char *t, *r;
2771         if ((t=(char *)malloc(strlen(s)+1))==0) {
2772             ERRMSG(0) "String storage space exhausted"
2773             EEND;
2774         }
2775         for (r=t; (*r++ = *s++)!=0; ) {
2776         }
2777         return t;
2778     }
2779     return NULL;
2780 }
2781
2782
2783 /* --------------------------------------------------------------------------
2784  * Compiler output
2785  * We can redirect compiler output (prompts, error messages, etc) by
2786  * tweaking these functions.
2787  * ------------------------------------------------------------------------*/
2788
2789 #ifdef HAVE_STDARG_H
2790 #include <stdarg.h>
2791 #else
2792 #include <varargs.h>
2793 #endif
2794
2795 Void hugsEnableOutput(f)
2796 Bool f; {
2797     disableOutput = !f;
2798 }
2799
2800 #ifdef HAVE_STDARG_H
2801 Void hugsPrintf(const char *fmt, ...) {
2802     va_list ap;                    /* pointer into argument list           */
2803     va_start(ap, fmt);             /* make ap point to first arg after fmt */
2804     if (!disableOutput) {
2805         vprintf(fmt, ap);
2806     } else {
2807     }
2808     va_end(ap);                    /* clean up                             */
2809 }
2810 #else
2811 Void hugsPrintf(fmt, va_alist)
2812 const char *fmt;
2813 va_dcl {
2814     va_list ap;                    /* pointer into argument list           */
2815     va_start(ap);                  /* make ap point to first arg after fmt */
2816     if (!disableOutput) {
2817         vprintf(fmt, ap);
2818     } else {
2819     }
2820     va_end(ap);                    /* clean up                             */
2821 }
2822 #endif
2823
2824 Void hugsPutchar(c)
2825 int c; {
2826     if (!disableOutput) {
2827         putchar(c);
2828     } else {
2829     }
2830 }
2831
2832 Void hugsFlushStdout() {
2833     if (!disableOutput) {
2834         fflush(stdout);
2835     }
2836 }
2837
2838 Void hugsFFlush(fp)
2839 FILE* fp; {
2840     if (!disableOutput) {
2841         fflush(fp);
2842     }
2843 }
2844
2845 #ifdef HAVE_STDARG_H
2846 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2847     va_list ap;
2848     va_start(ap, fmt);
2849     if (!disableOutput) {
2850         vfprintf(fp, fmt, ap);
2851     } else {
2852     }
2853     va_end(ap);
2854 }
2855 #else
2856 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2857 FILE* fp;
2858 const char* fmt;
2859 va_dcl {
2860     va_list ap;
2861     va_start(ap);
2862     if (!disableOutput) {
2863         vfprintf(fp, fmt, ap);
2864     } else {
2865     }
2866     va_end(ap);
2867 }
2868 #endif
2869
2870 Void hugsPutc(c, fp)
2871 int   c;
2872 FILE* fp; {
2873     if (!disableOutput) {
2874         putc(c,fp);
2875     } else {
2876     }
2877 }
2878
2879 /* --------------------------------------------------------------------------
2880  * Send message to each component of system:
2881  * ------------------------------------------------------------------------*/
2882
2883 Void everybody(what)            /* send command `what' to each component of*/
2884 Int what; {                     /* system to respond as appropriate ...    */
2885 #if 0
2886   fprintf ( stderr, "EVERYBODY %d\n", what );
2887 #endif
2888     machdep(what);              /* The order of calling each component is  */
2889     storage(what);              /* important for the PREPREL command       */
2890     substitution(what);
2891     input(what);
2892     translateControl(what);
2893     linkControl(what);
2894     staticAnalysis(what);
2895     deriveControl(what);
2896     typeChecker(what);
2897     compiler(what);
2898     codegen(what);
2899
2900     if (what == MARK) {
2901        mark(moduleGraph);
2902        mark(prelModules);
2903        mark(targetModules);
2904        mark(daSccs);
2905        mark(currentModule_failed);
2906     }
2907 }
2908
2909 /*-------------------------------------------------------------------------*/