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