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.78 $
  13  * $Date: 2000/06/28 10:42:17 $
  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 #  ifdef 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
 877 #  if defined(mingw32_TARGET_OS)
 878    /* Be wierd.  You can't longjmp in a signal handler,
 879       and posix signals are not supported.
 880    */
 881    if (newAction == HugsRtsInterrupt) {
 882       setHandler ( handler_RtsInterrupt );
 883    } else {
 884       signal(SIGINT,SIG_IGN);
 885    }
 886 #  else
 887    /* do it Right */
 888    switch (newAction) {
 889       case HugsIgnoreBreak:
 890          setHandler ( handler_IgnoreBreak ); break;
 891       case HugsLongjmpOnBreak:
 892          setHandler ( handler_LongjmpOnBreak ); break;
 893       case HugsRtsInterrupt:
 894          setHandler ( handler_RtsInterrupt ); break;
 895       default:
 896          internal("setBreakAction");
 897    }
 898 #  endif
 899
 900    return tmp;
 901 }
 902
 903
 904 /* --------------------------------------------------------------------------
 905  * The new module chaser, loader, etc
 906  * ------------------------------------------------------------------------*/
 907
 908 List    moduleGraph   = NIL;
 909 List    prelModules   = NIL;
 910 List    targetModules = NIL;
 911
 912 static String modeToString ( Cell mode )
 913 {
 914    switch (mode) {
 915       case FM_SOURCE: return "source";
 916       case FM_OBJECT: return "object";
 917       case FM_EITHER: return "source or object";
 918       default: internal("modeToString");
 919    }
 920 }
 921
 922 static Cell childMode ( Cell modeMeRequest, Cell modeMeActual )
 923 {
 924    assert(modeMeActual == FM_SOURCE ||
 925           modeMeActual == FM_OBJECT);
 926    assert(modeMeRequest == FM_SOURCE ||
 927           modeMeRequest == FM_OBJECT ||
 928           modeMeRequest == FM_EITHER);
 929    if (modeMeRequest == FM_SOURCE) return modeMeRequest;
 930    if (modeMeRequest == FM_OBJECT) return modeMeRequest;
 931    if (modeMeActual == FM_OBJECT) return FM_OBJECT;
 932    if (modeMeActual == FM_SOURCE) return FM_EITHER;
 933    internal("childMode");
 934 }
 935
 936 static Bool compatibleNewMode ( Cell modeNew, Cell modeExisting )
 937 {
 938    if (modeNew == FM_OBJECT && modeExisting == FM_OBJECT) return TRUE;
 939    if (modeNew == FM_SOURCE && modeExisting == FM_SOURCE) return TRUE;
 940    if (modeNew == FM_EITHER && modeExisting == FM_OBJECT) return TRUE;
 941    if (modeNew == FM_EITHER && modeExisting == FM_SOURCE) return TRUE;
 942    return FALSE;
 943 }
 944
 945 static void setCurrentFile ( Module mod )
 946 {
 947    assert(isModule(mod));
 948    strncpy(currentFileName, textToStr(module(mod).text), 990);
 949    strcat(currentFileName, textToStr(module(mod).srcExt));
 950    currentFile       = currentFileName;
 951    moduleBeingParsed = mod;
 952 }
 953
 954 static void clearCurrentFile ( void )
 955 {
 956    currentFile       = NULL;
 957    moduleBeingParsed = NIL;
 958 }
 959
 960 static void ppMG ( void )
 961 {
 962    List t,u,v;
 963    for (t = moduleGraph; nonNull(t); t=tl(t)) {
 964       u = hd(t);
 965       switch (whatIs(u)) {
 966          case GRP_NONREC:
 967             Printf ( "  %s\n", textToStr(textOf(snd(u))));
 968             break;
 969          case GRP_REC:
 970             Printf ( "  {" );
 971             for (v = snd(u); nonNull(v); v=tl(v))
 972                Printf ( "%s ", textToStr(textOf(hd(v))) );
 973             Printf ( "}\n" );
 974             break;
 975          default:
 976             internal("ppMG");
 977       }
 978    }
 979 }
 980
 981
 982 static Bool elemMG ( ConId mod )
 983 {
 984    List gs;
 985    for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
 986      switch (whatIs(hd(gs))) {
 987         case GRP_NONREC:
 988            if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
 989            break;
 990         case GRP_REC:
 991            if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
 992            break;
 993         default:
 994            internal("elemMG");
 995      }
 996   return FALSE;
 997 }
 998
 999
1000 static ConId selectArbitrarilyFromGroup ( Cell group )
1001 {
1002    switch (whatIs(group)) {
1003       case GRP_NONREC: return snd(group);
1004       case GRP_REC:    return hd(snd(group));
1005       default:         internal("selectArbitrarilyFromGroup");
1006    }
1007 }
1008
1009 static ConId selectLatestMG ( void )
1010 {
1011    List gs = moduleGraph;
1012    if (isNull(gs)) internal("selectLatestMG(1)");
1013    while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
1014    return selectArbitrarilyFromGroup(hd(gs));
1015 }
1016
1017
1018 static List /* of CONID */ listFromSpecifiedMG ( List mg )
1019 {
1020    List gs;
1021    List cs = NIL;
1022    for (gs = mg; nonNull(gs); gs=tl(gs)) {
1023       switch (whatIs(hd(gs))) {
1024         case GRP_REC:    cs = appendOnto(cs,snd(hd(gs))); break;
1025         case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
1026         default:         internal("listFromSpecifiedMG");
1027       }
1028    }
1029    return cs;
1030 }
1031
1032 static List /* of CONID */ listFromMG ( void )
1033 {
1034    return listFromSpecifiedMG ( moduleGraph );
1035 }
1036
1037
1038 /* Calculate the strongly connected components of modgList
1039    and assign them to moduleGraph.  Uses the .uses field of
1040    each of the modules to build the graph structure.
1041 */
1042 #define  SCC             modScc          /* make scc algorithm for StgVars */
1043 #define  LOWLINK         modLowlink
1044 #define  DEPENDS(t)      snd(t)
1045 #define  SETDEPENDS(c,v) snd(c)=v
1046 #include "scc.c"
1047 #undef   SETDEPENDS
1048 #undef   DEPENDS
1049 #undef   LOWLINK
1050 #undef   SCC
1051
1052 static void mgFromList ( List /* of CONID */ modgList )
1053 {
1054    List   t;
1055    List   u;
1056    Text   mT;
1057    List   usesT;
1058    List   adjList; /* :: [ (Text, [Text]) ] */
1059    Module mod;
1060    List   scc;
1061    Bool   isRec;
1062
1063    adjList = NIL;
1064    for (t = modgList; nonNull(t); t=tl(t)) {
1065       mT = textOf(hd(t));
1066       mod = findModule(mT);
1067       assert(nonNull(mod));
1068       usesT = NIL;
1069       for (u = module(mod).uses; nonNull(u); u=tl(u))
1070          usesT = cons(textOf(hd(u)),usesT);
1071
1072       /* artificially give all modules a dependency on Prelude */
1073       if (mT != textPrelude && mT != textPrelPrim)
1074          usesT = cons(textPrelude,usesT);
1075       adjList = cons(pair(mT,usesT),adjList);
1076    }
1077
1078    /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
1079       Modify this so that the adjacency list is a list of pointers
1080       back to bits of adjList -- that's what modScc needs.
1081    */
1082    for (t = adjList; nonNull(t); t=tl(t)) {
1083       List adj = NIL;
1084       /* for each elem of the adjacency list ... */
1085       for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
1086          List v;
1087          Text a = hd(u);
1088          /* find the element of adjList whose fst is a */
1089          for (v = adjList; nonNull(v); v=tl(v)) {
1090             assert(isText(a));
1091             assert(isText(fst(hd(v))));
1092             if (fst(hd(v))==a) break;
1093          }
1094          if (isNull(v)) internal("mgFromList");
1095          adj = cons(hd(v),adj);
1096       }
1097       snd(hd(t)) = adj;
1098    }
1099
1100    adjList = modScc ( adjList );
1101    /* adjList is now [ [(module-text, aux-info-field)] ] */
1102
1103    moduleGraph = NIL;
1104
1105    for (t = adjList; nonNull(t); t=tl(t)) {
1106
1107       scc = hd(t);
1108       /* scc :: [ (module-text, aux-info-field) ] */
1109       for (u = scc; nonNull(u); u=tl(u))
1110          hd(u) = mkCon(fst(hd(u)));
1111
1112       /* scc :: [CONID] */
1113       if (length(scc) > 1) {
1114          isRec = TRUE;
1115       } else {
1116          /* singleton module in scc; does it import itself? */
1117          mod = findModule ( textOf(hd(scc)) );
1118          assert(nonNull(mod));
1119          isRec = FALSE;
1120          for (u = module(mod).uses; nonNull(u); u=tl(u))
1121             if (textOf(hd(u))==textOf(hd(scc)))
1122                isRec = TRUE;
1123       }
1124
1125       if (isRec)
1126          moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
1127          moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
1128    }
1129    moduleGraph = reverse(moduleGraph);
1130 }
1131
1132
1133 static List /* of CONID */ getModuleImports ( Cell tree )
1134 {
1135    Cell  te;
1136    List  tes;
1137    ConId use;
1138    List  uses = NIL;
1139    for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
1140       te = hd(tes);
1141       switch(whatIs(te)) {
1142          case M_IMPORT_Q:
1143             use = zfst(unap(M_IMPORT_Q,te));
1144             assert(isCon(use));
1145             if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1146             break;
1147          case M_IMPORT_UNQ:
1148             use = zfst(unap(M_IMPORT_UNQ,te));
1149             assert(isCon(use));
1150             if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
1151             break;
1152          default:
1153             break;
1154       }
1155    }
1156    return uses;
1157 }
1158
1159
1160 static void processModule ( Module m )
1161 {
1162    Cell  tree;
1163    ConId modNm;
1164    List  topEnts;
1165    List  tes;
1166    Cell  te;
1167    Cell  te2;
1168
1169    tyconDefns     = NIL;
1170    typeInDefns    = NIL;
1171    valDefns       = NIL;
1172    classDefns     = NIL;
1173    instDefns      = NIL;
1174    selDefns       = NIL;
1175    genDefns       = NIL;
1176    unqualImports  = NIL;
1177    foreignImports = NIL;
1178    foreignExports = NIL;
1179    defaultDefns   = NIL;
1180    defaultLine    = 0;
1181    inputExpr      = NIL;
1182
1183    setCurrentFile(m);
1184    startModule(m);
1185    tree = unap(M_MODULE,module(m).tree);
1186    modNm = zfst3(tree);
1187
1188    if (textOf(modNm) != module(m).text) {
1189       ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"",
1190                 textToStr(textOf(modNm)),
1191                 textToStr(module(m).text),
1192                 textToStr(module(m).srcExt)
1193       EEND;
1194    }
1195
1196    setExportList(zsnd3(tree));
1197    topEnts = zthd3(tree);
1198
1199    for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1200       te  = hd(tes);
1201       assert(isGenPair(te));
1202       te2 = snd(te);
1203       switch(whatIs(te)) {
1204          case M_IMPORT_Q:
1205             addQualImport(zfst(te2),zsnd(te2));
1206             break;
1207          case M_IMPORT_UNQ:
1208             addUnqualImport(zfst(te2),zsnd(te2));
1209             break;
1210          case M_TYCON:
1211             tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1212             break;
1213          case M_CLASS:
1214             classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
1215             break;
1216          case M_INST:
1217             instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2));
1218             break;
1219          case M_DEFAULT:
1220             defaultDefn(intOf(zfst(te2)),zsnd(te2));
1221             break;
1222          case M_FOREIGN_IM:
1223             foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1224                           zsel45(te2),zsel55(te2));
1225             break;
1226          case M_FOREIGN_EX:
1227             foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
1228                           zsel45(te2),zsel55(te2));
1229          case M_VALUE:
1230             valDefns = cons(te2,valDefns);
1231             break;
1232          default:
1233             internal("processModule");
1234       }
1235    }
1236    checkDefns(m);
1237    typeCheckDefns();
1238    compileDefns();
1239 }
1240
1241
1242 static Module parseModuleOrInterface ( ConId mc, Cell modeRequest )
1243 {
1244    /* Allocate a module-table entry. */
1245    /* Parse the entity and fill in the .tree and .uses entries. */
1246    String path;
1247    String sExt;
1248    Bool sAvail;  Time sTime;  Long sSize;
1249    Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1250    Bool ok;
1251    Bool useSource;
1252    char name[10000];
1253
1254    Text   mt  = textOf(mc);
1255    Module mod = findModule ( mt );
1256
1257    /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1258                 textToStr(mt),mod); */
1259    if (nonNull(mod) && !module(mod).fake)
1260       internal("parseModuleOrInterface");
1261    if (nonNull(mod))
1262       module(mod).fake = FALSE;
1263
1264    if (isNull(mod))
1265       mod = newModule(mt);
1266
1267    /* This call malloc-ates path; we should deallocate it. */
1268    ok = findFilesForModule (
1269            textToStr(module(mod).text),
1270            &path,
1271            &sExt,
1272            &sAvail,  &sTime,  &sSize,
1273            &oiAvail, &oiTime, &oSize, &iSize
1274         );
1275
1276    if (!ok) goto cant_find;
1277    if (!sAvail && !oiAvail) goto cant_find;
1278
1279    /* Find out whether to use source or object. */
1280    switch (modeRequest) {
1281       case FM_SOURCE:
1282          if (!sAvail) goto cant_find;
1283          useSource = TRUE;
1284          break;
1285       case FM_OBJECT:
1286          if (!oiAvail) goto cant_find;
1287          useSource = FALSE;
1288          break;
1289       case FM_EITHER:
1290          if ( sAvail && !oiAvail) { useSource = TRUE; break; }
1291          if (!sAvail &&  oiAvail) { useSource = FALSE; break; }
1292          useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE;
1293          break;
1294       default:
1295          internal("parseModuleOrInterface");
1296    }
1297
1298    /* Actually do the parsing. */
1299    if (useSource) {
1300       module(mod).srcExt = findText(sExt);
1301       setCurrentFile(mod);
1302       strcpy(name, path);
1303       strcat(name, textToStr(mt));
1304       strcat(name, sExt);
1305       module(mod).tree      = parseModule(name,sSize);
1306       module(mod).uses      = getModuleImports(module(mod).tree);
1307       module(mod).mode      = FM_SOURCE;
1308       module(mod).lastStamp = sTime;
1309    } else {
1310       module(mod).srcExt = findText(HI_ENDING);
1311       setCurrentFile(mod);
1312       strcpy(name, path);
1313       strcat(name, textToStr(mt));
1314       strcat(name, DLL_ENDING);
1315       module(mod).objName = findText(name);
1316       module(mod).objSize = oSize;
1317       strcpy(name, path);
1318       strcat(name, textToStr(mt));
1319       strcat(name, ".u_hi");
1320       module(mod).tree      = parseInterface(name,iSize);
1321       module(mod).uses      = getInterfaceImports(module(mod).tree);
1322       module(mod).mode      = FM_OBJECT;
1323       module(mod).lastStamp = oiTime;
1324    }
1325
1326    if (path) free(path);
1327    return mod;
1328
1329   cant_find:
1330    if (path) free(path);
1331    clearCurrentFile();
1332    ERRMSG(0)
1333       "Can't find %s for module \"%s\"",
1334       modeToString(modeRequest), textToStr(mt)
1335    EEND;
1336 }
1337
1338
1339 static void tryLoadGroup ( Cell grp )
1340 {
1341    Module m;
1342    List   t;
1343    switch (whatIs(grp)) {
1344       case GRP_NONREC:
1345          m = findModule(textOf(snd(grp)));
1346          assert(nonNull(m));
1347          if (module(m).mode == FM_SOURCE) {
1348             processModule ( m );
1349             module(m).tree = NIL;
1350          } else {
1351             processInterfaces ( singleton(snd(grp)) );
1352             m = findModule(textOf(snd(grp)));
1353             assert(nonNull(m));
1354             module(m).tree = NIL;
1355          }
1356          break;
1357       case GRP_REC:
1358          for (t = snd(grp); nonNull(t); t=tl(t)) {
1359             m = findModule(textOf(hd(t)));
1360             assert(nonNull(m));
1361             if (module(m).mode == FM_SOURCE) {
1362                ERRMSG(0) "Source module \"%s\" imports itself recursively",
1363                          textToStr(textOf(hd(t)))
1364                EEND;
1365             }
1366          }
1367          processInterfaces ( snd(grp) );
1368          for (t = snd(grp); nonNull(t); t=tl(t)) {
1369             m = findModule(textOf(hd(t)));
1370             assert(nonNull(m));
1371             module(m).tree = NIL;
1372          }
1373          break;
1374       default:
1375          internal("tryLoadGroup");
1376    }
1377 }
1378
1379
1380 static void fallBackToPrelModules ( void )
1381 {
1382    Module m;
1383    for (m = MODULE_BASE_ADDR;
1384         m < MODULE_BASE_ADDR+tabModuleSz; m++)
1385       if (module(m).inUse
1386           && !varIsMember(module(m).text, prelModules))
1387          nukeModule(m);
1388 }
1389
1390
1391 /* This function catches exceptions in most of the system.
1392    So it's only ok for procedures called from this one
1393    to do EENDs (ie, write error messages).  Others should use
1394    EEND_NO_LONGJMP.
1395 */
1396 static void achieveTargetModules ( Bool loadingThePrelude )
1397 {
1398    volatile List   ood;
1399    volatile List   modgList;
1400    volatile List   t;
1401    volatile Module mod;
1402    volatile Bool   ok;
1403
1404    String path = NULL;
1405    String sExt = NULL;
1406    Bool sAvail;  Time sTime;  Long sSize;
1407    Bool oiAvail; Time oiTime; Long oSize; Long iSize;
1408
1409    volatile Time oisTime;
1410    volatile Bool out_of_date;
1411    volatile List ood_new;
1412    volatile List us;
1413    volatile List modgList_new;
1414    volatile List parsedButNotLoaded;
1415    volatile List toChase;
1416    volatile List trans_cl;
1417    volatile List trans_cl_new;
1418    volatile List u;
1419    volatile List mg;
1420    volatile List mg2;
1421    volatile Cell grp;
1422    volatile List badMods;
1423
1424    setBreakAction ( HugsIgnoreBreak );
1425
1426    /* First, examine timestamps to find out which modules are
1427       out of date with respect to the source/interface/object files.
1428    */
1429    ood      = NIL;
1430    modgList = listFromMG();
1431
1432    for (t = modgList; nonNull(t); t=tl(t)) {
1433
1434       if (varIsMember(textOf(hd(t)),prelModules))
1435          continue;
1436
1437       mod = findModule(textOf(hd(t)));
1438       if (isNull(mod)) internal("achieveTargetSet(1)");
1439
1440       /* In standalone mode, only succeeds for source modules. */
1441       ok = findFilesForModule (
1442               textToStr(module(mod).text),
1443               &path,
1444               &sExt,
1445               &sAvail,  &sTime,  &sSize,
1446               &oiAvail, &oiTime, &oSize, &iSize
1447            );
1448
1449       if (!combined && !sAvail) ok = FALSE;
1450       if (!ok) {
1451          fallBackToPrelModules();
1452          ERRMSG(0)
1453             "Can't find source or object+interface for module \"%s\"",
1454             textToStr(module(mod).text)
1455          EEND_NO_LONGJMP;
1456          if (path) free(path);
1457          return;
1458       }
1459
1460       if (sAvail && oiAvail) {
1461          oisTime = whicheverIsLater(sTime,oiTime);
1462       }
1463       else if (sAvail && !oiAvail) {
1464          oisTime = sTime;
1465       }
1466       else if (!sAvail && oiAvail) {
1467          oisTime = oiTime;
1468       }
1469       else {
1470          internal("achieveTargetSet(2)");
1471       }
1472
1473       out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1474       if (out_of_date) {
1475          assert(!varIsMember(textOf(hd(t)),ood));
1476          ood = cons(hd(t),ood);
1477       }
1478
1479       if (path) { free(path); path = NULL; };
1480    }
1481
1482    /* Second, form a simplistic transitive closure of the out-of-date
1483       modules: a module is out of date if it imports an out-of-date
1484       module.
1485    */
1486    while (1) {
1487       ood_new = NIL;
1488       for (t = modgList; nonNull(t); t=tl(t)) {
1489          mod = findModule(textOf(hd(t)));
1490          assert(nonNull(mod));
1491          for (us = module(mod).uses; nonNull(us); us=tl(us))
1492             if (varIsMember(textOf(hd(us)),ood))
1493                break;
1494          if (nonNull(us)) {
1495             if (varIsMember(textOf(hd(t)),prelModules))
1496                Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1497                         textToStr(textOf(hd(t))) );
1498             else
1499                if (!varIsMember(textOf(hd(t)),ood_new) &&
1500                    !varIsMember(textOf(hd(t)),ood))
1501                   ood_new = cons(hd(t),ood_new);
1502          }
1503       }
1504       if (isNull(ood_new)) break;
1505       ood = appendOnto(ood_new,ood);
1506    }
1507
1508    /* Now ood holds the entire set of modules which are out-of-date.
1509       Throw them out of the system, yielding a "reduced system",
1510       in which the remaining modules are in-date.
1511    */
1512    for (t = ood; nonNull(t); t=tl(t)) {
1513       mod = findModule(textOf(hd(t)));
1514       assert(nonNull(mod));
1515       nukeModule(mod);
1516    }
1517    modgList_new = NIL;
1518    for (t = modgList; nonNull(t); t=tl(t))
1519       if (!varIsMember(textOf(hd(t)),ood))
1520          modgList_new = cons(hd(t),modgList_new);
1521    modgList = modgList_new;
1522
1523    /* Update the module group list to reflect the reduced system.
1524       We do this so that if the following parsing phases fail, we can
1525       safely fall back to the reduced system.
1526    */
1527    mgFromList ( modgList );
1528
1529    /* Parse modules/interfaces, collecting parse trees and chasing
1530       imports, starting from the target set.
1531    */
1532    toChase = dupList(targetModules);
1533    for (t = toChase; nonNull(t); t=tl(t)) {
1534       Cell mode = (!combined)
1535                   ? FM_SOURCE
1536                   : ( (loadingThePrelude && combined)
1537                       ? FM_OBJECT
1538                       : FM_EITHER );
1539       hd(t) = zpair(hd(t), mode);
1540    }
1541
1542    /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */
1543
1544    parsedButNotLoaded = NIL;
1545
1546
1547    while (nonNull(toChase)) {
1548       ConId mc   = zfst(hd(toChase));
1549       Cell  mode = zsnd(hd(toChase));
1550       toChase    = tl(toChase);
1551       if (varIsMember(textOf(mc),modgList)
1552           || varIsMember(textOf(mc),parsedButNotLoaded)) {
1553          /* either exists fully, or is at least parsed */
1554          mod = findModule(textOf(mc));
1555          assert(nonNull(mod));
1556          if (!compatibleNewMode(mode,module(mod).mode)) {
1557             clearCurrentFile();
1558             ERRMSG(0)
1559                "module %s: %s required, but %s is more recent",
1560                textToStr(textOf(mc)), modeToString(mode),
1561                modeToString(module(mod).mode)
1562             EEND_NO_LONGJMP;
1563             goto parseException;
1564          }
1565       } else {
1566
1567          setBreakAction ( HugsLongjmpOnBreak );
1568          if (setjmp(catch_error)==0) {
1569             /* try this; it may throw an exception */
1570             mod = parseModuleOrInterface ( mc, mode );
1571          } else {
1572             /* here's the exception handler, if parsing fails */
1573             /* A parse error (or similar).  Clean up and abort. */
1574            parseException:
1575             setBreakAction ( HugsIgnoreBreak );
1576             mod = findModule(textOf(mc));
1577             if (nonNull(mod)) nukeModule(mod);
1578             for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1579                mod = findModule(textOf(hd(t)));
1580                assert(nonNull(mod));
1581                if (nonNull(mod)) nukeModule(mod);
1582             }
1583             return;
1584             /* end of the exception handler */
1585          }
1586          setBreakAction ( HugsIgnoreBreak );
1587
1588          parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1589          for (t = module(mod).uses; nonNull(t); t=tl(t))
1590             toChase = cons(
1591                         zpair( hd(t), childMode(mode,module(mod).mode) ),
1592                         toChase);
1593       }
1594    }
1595
1596    modgList = dupOnto(parsedButNotLoaded, modgList);
1597
1598    /* We successfully parsed all modules reachable from the target
1599       set which were not part of the reduced system.  However, there
1600       may be modules in the reduced system which are not reachable from
1601       the target set.  We detect these now by building the transitive
1602       closure of the target set, and nuking modules in the reduced
1603       system which are not part of that closure.
1604    */
1605    trans_cl = dupList(targetModules);
1606    while (1) {
1607       trans_cl_new = NIL;
1608       for (t = trans_cl; nonNull(t); t=tl(t)) {
1609          mod = findModule(textOf(hd(t)));
1610          assert(nonNull(mod));
1611          for (u = module(mod).uses; nonNull(u); u=tl(u))
1612             if (!varIsMember(textOf(hd(u)),trans_cl)
1613                 && !varIsMember(textOf(hd(u)),trans_cl_new)
1614                 && !varIsMember(textOf(hd(u)),prelModules))
1615                trans_cl_new = cons(hd(u),trans_cl_new);
1616       }
1617       if (isNull(trans_cl_new)) break;
1618       trans_cl = appendOnto(trans_cl_new,trans_cl);
1619    }
1620    modgList_new = NIL;
1621    for (t = modgList; nonNull(t); t=tl(t)) {
1622       if (varIsMember(textOf(hd(t)),trans_cl)) {
1623          modgList_new = cons(hd(t),modgList_new);
1624       } else {
1625          mod = findModule(textOf(hd(t)));
1626          assert(nonNull(mod));
1627          nukeModule(mod);
1628       }
1629    }
1630    modgList = modgList_new;
1631
1632    /* Now, the module symbol tables hold exactly the set of
1633       modules reachable from the target set, and modgList holds
1634       their names.   Calculate the scc-ified module graph,
1635       since we need that to guide the next stage, that of
1636       Actually Loading the modules.
1637
1638       If no errors occur, moduleGraph will reflect the final graph
1639       loaded.  If an error occurs loading a group, we nuke
1640       that group, truncate the moduleGraph just prior to that
1641       group, and exit.  That leaves the system having successfully
1642       loaded all groups prior to the one which failed.
1643    */
1644    mgFromList ( modgList );
1645
1646    for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1647       grp = hd(mg);
1648
1649       if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1650                        parsedButNotLoaded)) continue;
1651
1652       setBreakAction ( HugsLongjmpOnBreak );
1653       if (setjmp(catch_error)==0) {
1654          /* try this; it may throw an exception */
1655          tryLoadGroup(grp);
1656       } else {
1657          /* here's the exception handler, if static/typecheck etc fails */
1658          /* nuke the entire rest (ie, the unloaded part)
1659             of the module graph */
1660          setBreakAction ( HugsIgnoreBreak );
1661          badMods = listFromSpecifiedMG ( mg );
1662          for (t = badMods; nonNull(t); t=tl(t)) {
1663             mod = findModule(textOf(hd(t)));
1664             if (nonNull(mod)) nukeModule(mod);
1665          }
1666          /* truncate the module graph just prior to this group. */
1667          mg2 = NIL;
1668          mg = moduleGraph;
1669          while (TRUE) {
1670             if (isNull(mg)) break;
1671             if (hd(mg) == grp) break;
1672             mg2 = cons ( hd(mg), mg2 );
1673             mg = tl(mg);
1674          }
1675          moduleGraph = reverse(mg2);
1676          return;
1677          /* end of the exception handler */
1678       }
1679       setBreakAction ( HugsIgnoreBreak );
1680    }
1681
1682    /* Err .. I think that's it.  If we get here, we've successfully
1683       achieved the target set.  Phew!
1684    */
1685    setBreakAction ( HugsIgnoreBreak );
1686 }
1687
1688
1689 static Bool loadThePrelude ( void )
1690 {
1691    Bool ok;
1692    ConId conPrelude;
1693    ConId conPrelHugs;
1694    moduleGraph = prelModules = NIL;
1695
1696    if (combined) {
1697       conPrelude    = mkCon(findText("Prelude"));
1698       conPrelHugs   = mkCon(findText("PrelHugs"));
1699       targetModules = doubleton(conPrelude,conPrelHugs);
1700       achieveTargetModules(TRUE);
1701       ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1702    } else {
1703       conPrelude    = mkCon(findText("Prelude"));
1704       targetModules = singleton(conPrelude);
1705       achieveTargetModules(TRUE);
1706       ok = elemMG(conPrelude);
1707    }
1708
1709    if (ok) prelModules = listFromMG();
1710    return ok;
1711 }
1712
1713
1714 /* Refresh the current target modules, and attempt to set the
1715    current module to what it was before (ie currentModule):
1716      if currentModule_failed is different from currentModule,
1717         use that instead
1718      if nextCurrMod is non null, try to set it to that instead
1719      if the one we're after insn't available, select a target
1720        from the end of the module group list.
1721 */
1722 static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
1723 {
1724    List t;
1725    ConId tryFor;
1726
1727    /* Remember what the old current module was. */
1728    tryFor = mkCon(module(currentModule).text);
1729
1730    /* Do the Real Work. */
1731    achieveTargetModules(FALSE);
1732
1733    /* Remember if the current module was invalidated by this
1734       refresh, so later refreshes can attempt to reload it. */
1735    if (!elemMG(tryFor))
1736       currentModule_failed = tryFor;
1737
1738    /* If a previous refresh failed to get an old current module,
1739       try for that instead. */
1740    if (nonNull(currentModule_failed)
1741        && textOf(currentModule_failed) != textOf(tryFor)
1742        && elemMG(currentModule_failed))
1743       tryFor = currentModule_failed;
1744    /* If our caller specified a new current module, that overrides
1745       all historical settings. */
1746    if (nonNull(nextCurrMod))
1747       tryFor = nextCurrMod;
1748    /* Finally, if we can't actually get hold of whatever it was we
1749       were after, select something which is possible. */
1750    if (!elemMG(tryFor))
1751       tryFor = selectLatestMG();
1752
1753    /* combined mode kludge, to get Prelude rather than PrelHugs */
1754    if (combined && textOf(tryFor)==findText("PrelHugs"))
1755       tryFor = mkCon(findText("Prelude"));
1756
1757    if (cleanAfter) {
1758       /* delete any targetModules which didn't actually get loaded  */
1759       t = targetModules;
1760       targetModules = NIL;
1761       for (; nonNull(t); t=tl(t))
1762          if (elemMG(hd(t)))
1763             targetModules = cons(hd(t),targetModules);
1764    }
1765
1766    setCurrModule ( findModule(textOf(tryFor)) );
1767    Printf("Hugs session for:\n");
1768    ppMG();
1769 }
1770
1771
1772 static void addActions ( List extraModules /* :: [CONID] */ )
1773 {
1774    List t;
1775    for (t = extraModules; nonNull(t); t=tl(t)) {
1776       ConId extra = hd(t);
1777       if (!varIsMember(textOf(extra),targetModules))
1778          targetModules = cons(extra,targetModules);
1779    }
1780    refreshActions ( isNull(extraModules)
1781                        ? NIL
1782                        : hd(reverse(extraModules)),
1783                     TRUE
1784                   );
1785 }
1786
1787
1788 static void loadActions ( List loadModules /* :: [CONID] */ )
1789 {
1790    List t;
1791    targetModules = dupList ( prelModules );
1792
1793    for (t = loadModules; nonNull(t); t=tl(t)) {
1794       ConId load = hd(t);
1795       if (!varIsMember(textOf(load),targetModules))
1796          targetModules = cons(load,targetModules);
1797    }
1798    refreshActions ( isNull(loadModules)
1799                        ? NIL
1800                        : hd(reverse(loadModules)),
1801                     TRUE
1802                   );
1803 }
1804
1805
1806 /* --------------------------------------------------------------------------
1807  * Access to external editor:
1808  * ------------------------------------------------------------------------*/
1809
1810 /* ToDo: All this editor stuff needs fixing. */
1811
1812 static Void local editor() {            /* interpreter-editor interface    */
1813 #if 0
1814     String newFile  = readFilename();
1815     if (newFile) {
1816         setLastEdit(newFile,0);
1817         if (readFilename()) {
1818             ERRMSG(0) "Multiple filenames not permitted"
1819             EEND;
1820         }
1821     }
1822     runEditor();
1823 #endif
1824 }
1825
1826 static Void local find() {              /* edit file containing definition */
1827 #if 0
1828 ToDo: Fix!
1829     String nm = readFilename();         /* of specified name               */
1830     if (!nm) {
1831         ERRMSG(0) "No name specified"
1832         EEND;
1833     }
1834     else if (readFilename()) {
1835         ERRMSG(0) "Multiple names not permitted"
1836         EEND;
1837     }
1838     else {
1839         Text t;
1840         Cell c;
1841         setCurrModule(findEvalModule());
1842         startNewScript(0);
1843         if (nonNull(c=findTycon(t=findText(nm)))) {
1844             if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1845                 readScripts(N_PRELUDE_SCRIPTS);
1846             }
1847         } else if (nonNull(c=findName(t))) {
1848             if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1849                 readScripts(N_PRELUDE_SCRIPTS);
1850             }
1851         } else {
1852             ERRMSG(0) "No current definition for name \"%s\"", nm
1853             EEND;
1854         }
1855     }
1856 #endif
1857 }
1858
1859 static Void local runEditor() {         /* run editor on script lastEdit   */
1860 #if 0
1861     if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine              */
1862         readScripts(N_PRELUDE_SCRIPTS);
1863 #endif
1864 }
1865
1866 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1867 String fname;
1868 Int    line; {
1869 #if 0
1870     if (lastEdit)
1871         free(lastEdit);
1872     lastEdit = strCopy(fname);
1873     lastEdLine = line;
1874 #endif
1875 }
1876
1877 /* --------------------------------------------------------------------------
1878  * Read and evaluate an expression:
1879  * ------------------------------------------------------------------------*/
1880
1881 static Void setModule ( void ) {
1882                               /*set module in which to evaluate expressions*/
1883    Module m;
1884    ConId  mc = NIL;
1885    String s  = readFilename();
1886    if (!s) {
1887       mc = selectLatestMG();
1888       if (combined && textOf(mc)==findText("PrelHugs"))
1889          mc = mkCon(findText("Prelude"));
1890       m = findModule(textOf(mc));
1891       assert(nonNull(m));
1892    } else {
1893       m = findModule(findText(s));
1894       if (isNull(m)) {
1895          ERRMSG(0) "Cannot find module \"%s\"", s
1896          EEND_NO_LONGJMP;
1897          return;
1898       }
1899    }
1900    setCurrModule(m);
1901 }
1902
1903 static Module allocEvalModule ( void )
1904 {
1905    Module evalMod = newModule( findText("_Eval_Module_") );
1906    module(evalMod).names   = module(currentModule).names;
1907    module(evalMod).tycons  = module(currentModule).tycons;
1908    module(evalMod).classes = module(currentModule).classes;
1909    module(evalMod).qualImports
1910      = singleton(pair(mkCon(textPrelude),modulePrelude));
1911    return evalMod;
1912 }
1913
1914 static Void local evaluator() {        /* evaluate expr and print value    */
1915     volatile Type   type;
1916     volatile Type   bd;
1917     volatile Kinds  ks      = NIL;
1918     volatile Module evalMod = allocEvalModule();
1919     volatile Module currMod = currentModule;
1920     setCurrModule(evalMod);
1921     currentFile = NULL;
1922
1923     defaultDefns = combined ? stdDefaults : evalDefaults;
1924
1925     setBreakAction ( HugsLongjmpOnBreak );
1926     if (setjmp(catch_error)==0) {
1927        /* try this */
1928        parseExp();
1929        checkExp();
1930        type = typeCheckExp(TRUE);
1931     } else {
1932        /* if an exception happens, we arrive here */
1933        setBreakAction ( HugsIgnoreBreak );
1934        goto cleanup_and_return;
1935     }
1936
1937     setBreakAction ( HugsIgnoreBreak );
1938     if (isPolyType(type)) {
1939         ks = polySigOf(type);
1940         bd = monotypeOf(type);
1941     }
1942     else
1943         bd = type;
1944
1945     if (whatIs(bd)==QUAL) {
1946         printing = FALSE;
1947        clearCurrentFile();
1948        ERRMSG(0) "Unresolved overloading" ETHEN
1949        ERRTEXT   "\n*** Type       : "    ETHEN ERRTYPE(type);
1950        ERRTEXT   "\n*** Expression : "    ETHEN ERREXPR(inputExpr);
1951        ERRTEXT   "\n"
1952        EEND_NO_LONGJMP;
1953        goto cleanup_and_return;
1954     }
1955
1956 #if 1
1957     printing      = TRUE;
1958     numEnters     = 0;
1959     if (isProgType(ks,bd)) {
1960         inputExpr = ap(nameRunIO_toplevel,inputExpr);
1961         evalExp();
1962         Putchar('\n');
1963     } else {
1964         Cell d = provePred(ks,NIL,ap(classShow,bd));
1965         if (isNull(d)) {
1966            clearCurrentFile();
1967            printing = FALSE;
1968            ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1969            ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
1970            ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
1971            ERRTEXT   "\n"
1972            EEND_NO_LONGJMP;
1973            goto cleanup_and_return;
1974         }
1975         inputExpr = ap2(nameShow,           d,inputExpr);
1976         inputExpr = ap (namePutStr,         inputExpr);
1977         inputExpr = ap (nameRunIO_toplevel, inputExpr);
1978
1979         evalExp(); printf("\n");
1980         if (addType) {
1981             printf(" :: ");
1982             printType(stdout,type);
1983             Putchar('\n');
1984         }
1985     }
1986
1987 #else
1988
1989    printf ( "result type is " );
1990    printType ( stdout, type );
1991    printf ( "\n" );
1992    evalExp();
1993    printf ( "\n" );
1994
1995 #endif
1996
1997   cleanup_and_return:
1998    setBreakAction ( HugsIgnoreBreak );
1999    nukeModule(evalMod);
2000    setCurrModule(currMod);
2001    setCurrentFile(currMod);
2002    stopAnyPrinting();
2003 }
2004
2005
2006
2007 /* --------------------------------------------------------------------------
2008  * Print type of input expression:
2009  * ------------------------------------------------------------------------*/
2010
2011 static Void showtype ( void ) {        /* print type of expression (if any)*/
2012
2013     volatile Cell   type;
2014     volatile Module evalMod = allocEvalModule();
2015     volatile Module currMod = currentModule;
2016     setCurrModule(evalMod);
2017
2018     if (setjmp(catch_error)==0) {
2019        /* try this */
2020        parseExp();
2021        checkExp();
2022        defaultDefns = evalDefaults;
2023        type = typeCheckExp(FALSE);
2024        printExp(stdout,inputExpr);
2025        Printf(" :: ");
2026        printType(stdout,type);
2027        Putchar('\n');
2028     } else {
2029        /* if an exception happens, we arrive here */
2030     }
2031
2032     nukeModule(evalMod);
2033     setCurrModule(currMod);
2034 }
2035
2036
2037 static Void local browseit(mod,t,all)
2038 Module mod;
2039 String t;
2040 Bool all; {
2041     if (nonNull(mod)) {
2042         Cell cs;
2043         if (nonNull(t))
2044             Printf("module %s where\n",textToStr(module(mod).text));
2045         for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
2046             Name nm = hd(cs);
2047             /* only look at things defined in this module,
2048                unless `all' flag is set */
2049             if (all || name(nm).mod == mod) {
2050                 /* unwanted artifacts, like lambda lifted values,
2051                    are in the list of names, but have no types */
2052                 if (nonNull(name(nm).type)) {
2053                     printExp(stdout,nm);
2054                     Printf(" :: ");
2055                     printType(stdout,name(nm).type);
2056                     if (isCfun(nm)) {
2057                         Printf("  -- data constructor");
2058                     } else if (isMfun(nm)) {
2059                         Printf("  -- class member");
2060                     } else if (isSfun(nm)) {
2061                         Printf("  -- selector function");
2062                     }
2063                     Printf("\n");
2064                 }
2065             }
2066         }
2067     } else {
2068       if (isNull(mod)) {
2069         Printf("Unknown module %s\n",t);
2070       }
2071     }
2072 }
2073
2074 static Void local browse() {            /* browse modules                  */
2075     Int    count = 0;                   /* or give menu of commands        */
2076     String s;
2077     Bool all = FALSE;
2078
2079     for (; (s=readFilename())!=0; count++)
2080         if (strcmp(s,"all") == 0) {
2081             all = TRUE;
2082             --count;
2083         } else
2084             browseit(findModule(findText(s)),s,all);
2085     if (count == 0) {
2086         browseit(currentModule,NULL,all);
2087     }
2088 }
2089
2090 #if EXPLAIN_INSTANCE_RESOLUTION
2091 static Void local xplain() {         /* print type of expression (if any)*/
2092     Cell d;
2093     Bool sir = showInstRes;
2094
2095     setCurrModule(findEvalModule());
2096     startNewScript(0);                 /* Enables recovery of storage      */
2097                                        /* allocated during evaluation      */
2098     parseContext();
2099     checkContext();
2100     showInstRes = TRUE;
2101     d = provePred(NIL,NIL,hd(inputContext));
2102     if (isNull(d)) {
2103         fprintf(stdout, "not Sat\n");
2104     } else {
2105         fprintf(stdout, "Sat\n");
2106     }
2107     showInstRes = sir;
2108 }
2109 #endif
2110
2111 /* --------------------------------------------------------------------------
2112  * Enhanced help system:  print current list of scripts or give information
2113  * about an object.
2114  * ------------------------------------------------------------------------*/
2115
2116 static String local objToStr(m,c)
2117 Module m;
2118 Cell   c; {
2119 #if 1 || DISPLAY_QUANTIFIERS
2120     static char newVar[60];
2121     switch (whatIs(c)) {
2122         case NAME  : if (m == name(c).mod) {
2123                          sprintf(newVar,"%s", textToStr(name(c).text));
2124                      } else {
2125                          sprintf(newVar,"%s.%s",
2126                                         textToStr(module(name(c).mod).text),
2127                                         textToStr(name(c).text));
2128                      }
2129                      break;
2130
2131         case TYCON : if (m == tycon(c).mod) {
2132                          sprintf(newVar,"%s", textToStr(tycon(c).text));
2133                      } else {
2134                          sprintf(newVar,"%s.%s",
2135                                         textToStr(module(tycon(c).mod).text),
2136                                         textToStr(tycon(c).text));
2137                      }
2138                      break;
2139
2140         case CLASS : if (m == cclass(c).mod) {
2141                          sprintf(newVar,"%s", textToStr(cclass(c).text));
2142                      } else {
2143                          sprintf(newVar,"%s.%s",
2144                                         textToStr(module(cclass(c).mod).text),
2145                                         textToStr(cclass(c).text));
2146                      }
2147                      break;
2148
2149         default    : internal("objToStr");
2150     }
2151     return newVar;
2152 #else
2153     static char newVar[33];
2154     switch (whatIs(c)) {
2155         case NAME  : sprintf(newVar,"%s", textToStr(name(c).text));
2156                      break;
2157
2158         case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
2159                      break;
2160
2161         case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
2162                      break;
2163
2164         default    : internal("objToStr");
2165     }
2166     return newVar;
2167 #endif
2168 }
2169
2170 extern Name nameHw;
2171
2172 static Void dumpStg ( void )
2173 {
2174    String s;
2175    Int i;
2176 #if 0
2177    Whats this for?
2178    setCurrModule(findEvalModule());
2179    startNewScript(0);
2180 #endif
2181    s = readFilename();
2182
2183    /* request to locate a symbol by name */
2184    if (s && (*s == '?')) {
2185       Text t = findText(s+1);
2186       locateSymbolByName(t);
2187       return;
2188    }
2189
2190    /* request to dump a bit of the heap */
2191    if (s && (*s == '-' || isdigit(*s))) {
2192       int i = atoi(s);
2193       print(i,100);
2194       printf("\n");
2195       return;
2196    }
2197
2198    /* request to dump a symbol table entry */
2199    if (!s
2200        || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
2201        || !isdigit(s[1])) {
2202       fprintf(stderr, ":d -- bad request `%s'\n", s );
2203       return;
2204    }
2205    i = atoi(s+1);
2206    switch (*s) {
2207       case 't': dumpTycon(i); break;
2208       case 'n': dumpName(i); break;
2209       case 'c': dumpClass(i); break;
2210       case 'i': dumpInst(i); break;
2211       default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
2212    }
2213 }
2214
2215
2216 #if 0
2217 static Void local dumpStg( void ) {       /* print STG stuff                 */
2218     String s;
2219     Text   t;
2220     Name   n;
2221     Int    i;
2222     Cell   v;                           /* really StgVar */
2223     setCurrModule(findEvalModule());
2224     startNewScript(0);
2225     for (; (s=readFilename())!=0;) {
2226         t = findText(s);
2227         v = n = NIL;
2228         /* find the name while ignoring module scopes */
2229         for (i=NAMEMIN; i<nameHw; i++)
2230            if (name(i).text == t) n = i;
2231
2232         /* perhaps it's an "idNNNNNN" thing? */
2233         if (isNull(n) &&
2234             strlen(s) >= 3 &&
2235             s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2236            v = 0;
2237            i = 2;
2238            while (isdigit(s[i])) {
2239               v = v * 10 + (s[i]-'0');
2240               i++;
2241            }
2242            v = -v;
2243            n = nameFromStgVar(v);
2244         }
2245
2246         if (isNull(n) && whatIs(v)==STGVAR) {
2247            Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2248            printStg(stderr, v );
2249         } else
2250         if (isNull(n)) {
2251            Printf ( "Unknown reference `%s'\n", s );
2252         } else
2253         if (!isName(n)) {
2254            Printf ( "Not a Name: `%s'\n", s );
2255         } else
2256         if (isNull(name(n).stgVar)) {
2257            Printf ( "Doesn't have a STG tree: %s\n", s );
2258         } else {
2259            Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2260            printStg(stderr, name(n).stgVar);
2261         }
2262     }
2263 }
2264 #endif
2265
2266 static Void local info() {              /* describe objects                */
2267     Int    count = 0;                   /* or give menu of commands        */
2268     String s;
2269
2270     for (; (s=readFilename())!=0; count++) {
2271         describe(findText(s));
2272     }
2273     if (count == 0) {
2274        /* whatScripts(); */
2275     }
2276 }
2277
2278
2279 static Void local describe(t)           /* describe an object              */
2280 Text t; {
2281     Tycon  tc  = findTycon(t);
2282     Class  cl  = findClass(t);
2283     Name   nm  = findName(t);
2284
2285     if (nonNull(tc)) {                  /* as a type constructor           */
2286         Type t = tc;
2287         Int  i;
2288         Inst in;
2289         for (i=0; i<tycon(tc).arity; ++i) {
2290             t = ap(t,mkOffset(i));
2291         }
2292         Printf("-- type constructor");
2293         if (kindExpert) {
2294             Printf(" with kind ");
2295             printKind(stdout,tycon(tc).kind);
2296         }
2297         Putchar('\n');
2298         switch (tycon(tc).what) {
2299             case SYNONYM      : Printf("type ");
2300                                 printType(stdout,t);
2301                                 Printf(" = ");
2302                                 printType(stdout,tycon(tc).defn);
2303                                 break;
2304
2305             case NEWTYPE      :
2306             case DATATYPE     : {   List cs = tycon(tc).defn;
2307                                     if (tycon(tc).what==DATATYPE) {
2308                                         Printf("data ");
2309                                     } else {
2310                                         Printf("newtype ");
2311                                     }
2312                                     printType(stdout,t);
2313                                     Putchar('\n');
2314                                     mapProc(printSyntax,cs);
2315                                     if (hasCfun(cs)) {
2316                                         Printf("\n-- constructors:");
2317                                     }
2318                                     for (; hasCfun(cs); cs=tl(cs)) {
2319                                         Putchar('\n');
2320                                         printExp(stdout,hd(cs));
2321                                         Printf(" :: ");
2322                                         printType(stdout,name(hd(cs)).type);
2323                                     }
2324                                     if (nonNull(cs)) {
2325                                         Printf("\n-- selectors:");
2326                                     }
2327                                     for (; nonNull(cs); cs=tl(cs)) {
2328                                         Putchar('\n');
2329                                         printExp(stdout,hd(cs));
2330                                         Printf(" :: ");
2331                                         printType(stdout,name(hd(cs)).type);
2332                                     }
2333                                 }
2334                                 break;
2335
2336             case RESTRICTSYN  : Printf("type ");
2337                                 printType(stdout,t);
2338                                 Printf(" = <restricted>");
2339                                 break;
2340         }
2341         Putchar('\n');
2342         if (nonNull(in=findFirstInst(tc))) {
2343             Printf("\n-- instances:\n");
2344             do {
2345                 showInst(in);
2346                 in = findNextInst(tc,in);
2347             } while (nonNull(in));
2348         }
2349         Putchar('\n');
2350     }
2351
2352     if (nonNull(cl)) {                  /* as a class                      */
2353         List  ins = cclass(cl).instances;
2354         Kinds ks  = cclass(cl).kinds;
2355         if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2356             Printf("-- type class");
2357         } else {
2358             Printf("-- constructor class");
2359             if (kindExpert) {
2360                 Printf(" with arity ");
2361                 printKinds(stdout,ks);
2362             }
2363         }
2364         Putchar('\n');
2365         mapProc(printSyntax,cclass(cl).members);
2366         Printf("class ");
2367         if (nonNull(cclass(cl).supers)) {
2368             printContext(stdout,cclass(cl).supers);
2369             Printf(" => ");
2370         }
2371         printPred(stdout,cclass(cl).head);
2372
2373         if (nonNull(cclass(cl).fds)) {
2374             List   fds = cclass(cl).fds;
2375             String pre = " | ";
2376             for (; nonNull(fds); fds=tl(fds)) {
2377                 Printf(pre);
2378                 printFD(stdout,hd(fds));
2379                 pre = ", ";
2380             }
2381         }
2382
2383         if (nonNull(cclass(cl).members)) {
2384             List ms = cclass(cl).members;
2385             Printf(" where");
2386             do {
2387                 Type t = name(hd(ms)).type;
2388                 if (isPolyType(t)) {
2389                     t = monotypeOf(t);
2390                 }
2391                 Printf("\n  ");
2392                 printExp(stdout,hd(ms));
2393                 Printf(" :: ");
2394                 if (isNull(tl(fst(snd(t))))) {
2395                     t = snd(snd(t));
2396                 } else {
2397                     t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2398                 }
2399                 printType(stdout,t);
2400                 ms = tl(ms);
2401             } while (nonNull(ms));
2402         }
2403         Putchar('\n');
2404         if (nonNull(ins)) {
2405             Printf("\n-- instances:\n");
2406             do {
2407                 showInst(hd(ins));
2408                 ins = tl(ins);
2409             } while (nonNull(ins));
2410         }
2411         Putchar('\n');
2412     }
2413
2414     if (nonNull(nm)) {                  /* as a function/name              */
2415         printSyntax(nm);
2416         printExp(stdout,nm);
2417         Printf(" :: ");
2418         if (nonNull(name(nm).type)) {
2419             printType(stdout,name(nm).type);
2420         } else {
2421             Printf("<unknown type>");
2422         }
2423         if (isCfun(nm)) {
2424             Printf("  -- data constructor");
2425         } else if (isMfun(nm)) {
2426             Printf("  -- class member");
2427         } else if (isSfun(nm)) {
2428             Printf("  -- selector function");
2429         }
2430         Printf("\n\n");
2431     }
2432
2433
2434     if (isNull(tc) && isNull(cl) && isNull(nm)) {
2435         Printf("Unknown reference `%s'\n",textToStr(t));
2436     }
2437 }
2438
2439 static Void local printSyntax(nm)
2440 Name nm; {
2441     Syntax sy = syntaxOf(nm);
2442     Text   t  = name(nm).text;
2443     String s  = textToStr(t);
2444     if (sy != defaultSyntax(t)) {
2445         Printf("infix");
2446         switch (assocOf(sy)) {
2447             case LEFT_ASS  : Putchar('l'); break;
2448             case RIGHT_ASS : Putchar('r'); break;
2449             case NON_ASS   : break;
2450         }
2451         Printf(" %i ",precOf(sy));
2452         if (isascii((int)(*s)) && isalpha((int)(*s))) {
2453             Printf("`%s`",s);
2454         } else {
2455             Printf("%s",s);
2456         }
2457         Putchar('\n');
2458     }
2459 }
2460
2461 static Void local showInst(in)          /* Display instance decl header    */
2462 Inst in; {
2463     Printf("instance ");
2464     if (nonNull(inst(in).specifics)) {
2465         printContext(stdout,inst(in).specifics);
2466         Printf(" => ");
2467     }
2468     printPred(stdout,inst(in).head);
2469     Putchar('\n');
2470 }
2471
2472 /* --------------------------------------------------------------------------
2473  * List all names currently in scope:
2474  * ------------------------------------------------------------------------*/
2475
2476 static Void local listNames() {         /* list names matching optional pat*/
2477     String pat   = readFilename();
2478     List   names = NIL;
2479     Int    width = 72;
2480     Int    count = 0;
2481     Int    termPos;
2482     Module mod   = currentModule;
2483
2484     if (pat) {                          /* First gather names to list      */
2485         do {
2486             names = addNamesMatching(pat,names);
2487         } while ((pat=readFilename())!=0);
2488     } else {
2489         names = addNamesMatching((String)0,names);
2490     }
2491     if (isNull(names)) {                /* Then print them out             */
2492         clearCurrentFile();
2493         ERRMSG(0) "No names selected"
2494         EEND_NO_LONGJMP;
2495         return;
2496     }
2497     for (termPos=0; nonNull(names); names=tl(names)) {
2498         String s = objToStr(mod,hd(names));
2499         Int    l = strlen(s);
2500         if (termPos+1+l>width) {
2501             Putchar('\n');
2502             termPos = 0;
2503         } else if (termPos>0) {
2504             Putchar(' ');
2505             termPos++;
2506         }
2507         Printf("%s",s);
2508         termPos += l;
2509         count++;
2510     }
2511     Printf("\n(%d names listed)\n", count);
2512 }
2513
2514 /* --------------------------------------------------------------------------
2515  * print a prompt and read a line of input:
2516  * ------------------------------------------------------------------------*/
2517
2518 static Void local promptForInput(moduleName)
2519 String moduleName; {
2520     char promptBuffer[1000];
2521 #if 1
2522     /* This is portable but could overflow buffer */
2523     sprintf(promptBuffer,prompt,moduleName);
2524 #else
2525     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2526      * promptBuffer instead.
2527      */
2528     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2529         /* Reset prompt to a safe default to avoid an infinite loop */
2530         free(prompt);
2531         prompt = strCopy("? ");
2532         internal("Combined prompt and evaluation module name too long");
2533     }
2534 #endif
2535     if (autoMain)
2536        stringInput("main\0"); else
2537        consoleInput(promptBuffer);
2538 }
2539
2540 /* --------------------------------------------------------------------------
2541  * main read-eval-print loop, with error trapping:
2542  * ------------------------------------------------------------------------*/
2543
2544 static Void local interpreter(argc,argv)/* main interpreter loop           */
2545 Int    argc;
2546 String argv[]; {
2547
2548     List   modConIds; /* :: [CONID] */
2549     Bool   prelOK;
2550     String s;
2551
2552     setBreakAction ( HugsIgnoreBreak );
2553     modConIds = initialize(argc,argv);  /* the initial modules to load     */
2554     setBreakAction ( HugsIgnoreBreak );
2555     prelOK    = loadThePrelude();
2556
2557     if (!prelOK) {
2558        if (autoMain)
2559           fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2560        else
2561           fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2562        exit(1);
2563     }
2564
2565     if (combined) everybody(POSTPREL);
2566     loadActions(modConIds);
2567
2568     if (autoMain) {
2569        for (; nonNull(modConIds); modConIds=tl(modConIds))
2570           if (!elemMG(hd(modConIds))) {
2571              fprintf(stderr,
2572                      "hugs +Q: compilation failed -- can't run `main'\n" );
2573              exit(1);
2574           }
2575     }
2576
2577     modConIds = NIL;
2578
2579     /* initialize calls startupHaskell, which trashes our signal handlers */
2580     setBreakAction ( HugsIgnoreBreak );
2581     forHelp();
2582
2583     for (;;) {
2584         Command cmd;
2585         everybody(RESET);               /* reset to sensible initial state */
2586
2587         promptForInput(textToStr(module(currentModule).text));
2588
2589         cmd = readCommand(cmds, (Char)':', (Char)'!');
2590         switch (cmd) {
2591             case EDIT   : editor();
2592                           break;
2593             case FIND   : find();
2594                           break;
2595             case LOAD   : modConIds = NIL;
2596                 while ((s=readFilename())!=0) {
2597                           modConIds = cons(mkCon(findText(s)),modConIds);
2598
2599                 }
2600                           loadActions(modConIds);
2601                           modConIds = NIL;
2602                           break;
2603             case ALSO   : modConIds = NIL;
2604                           while ((s=readFilename())!=0)
2605                              modConIds = cons(mkCon(findText(s)),modConIds);
2606                           addActions(modConIds);
2607                           modConIds = NIL;
2608                           break;
2609             case RELOAD : refreshActions(NIL,FALSE);
2610                           break;
2611             case SETMODULE :
2612                           setModule();
2613                           break;
2614             case EVAL   : evaluator();
2615                           break;
2616             case TYPEOF : showtype();
2617                           break;
2618             case BROWSE : browse();
2619                           break;
2620 #if EXPLAIN_INSTANCE_RESOLUTION
2621             case XPLAIN : xplain();
2622                           break;
2623 #endif
2624             case NAMES  : listNames();
2625                           break;
2626             case HELP   : menu();
2627                           break;
2628             case BADCMD : guidance();
2629                           break;
2630             case SET    : set();
2631                           break;
2632             case SYSTEM : if (shellEsc(readLine()))
2633                               Printf("Warning: Shell escape terminated abnormally\n");
2634                           break;
2635             case CHGDIR : changeDir();
2636                           break;
2637             case INFO   : info();
2638                           break;
2639             case PNTVER: Printf("-- Hugs Version %s\n",
2640                                  HUGS_VERSION);
2641                           break;
2642             case DUMP   : dumpStg();
2643                           break;
2644             case QUIT   : return;
2645             case COLLECT: consGC = FALSE;
2646                           garbageCollect();
2647                           consGC = TRUE;
2648                           Printf("Garbage collection recovered %d cells\n",
2649                                  cellsRecovered);
2650                           break;
2651             case NOCMD  : break;
2652         }
2653
2654         if (autoMain) break;
2655     }
2656 }
2657
2658 /* --------------------------------------------------------------------------
2659  * Display progress towards goal:
2660  * ------------------------------------------------------------------------*/
2661
2662 static Target currTarget;
2663 static Bool   aiming = FALSE;
2664 static Int    currPos;
2665 static Int    maxPos;
2666 static Int    charCount;
2667
2668 Void setGoal(what, t)                  /* Set goal for what to be t        */
2669 String what;
2670 Target t; {
2671     if (quiet)
2672       return;
2673 #if EXPLAIN_INSTANCE_RESOLUTION
2674     if (showInstRes)
2675       return;
2676 #endif
2677     currTarget = (t?t:1);
2678     aiming     = TRUE;
2679     for (charCount=0; *what; charCount++)
2680         Putchar(*what++);
2681     FlushStdout();
2682 }
2683
2684 Void soFar(t)                          /* Indicate progress towards goal   */
2685 Target t; {                            /* has now reached t                */
2686     if (quiet)
2687       return;
2688 #if EXPLAIN_INSTANCE_RESOLUTION
2689     if (showInstRes)
2690       return;
2691 #endif
2692 }
2693
2694 Void done() {                          /* Goal has now been achieved       */
2695     if (quiet)
2696       return;
2697 #if EXPLAIN_INSTANCE_RESOLUTION
2698     if (showInstRes)
2699       return;
2700 #endif
2701     for (; charCount>0; charCount--) {
2702         Putchar('\b');
2703         Putchar(' ');
2704         Putchar('\b');
2705     }
2706     aiming = FALSE;
2707     FlushStdout();
2708 }
2709
2710 static Void local failed() {           /* Goal cannot be reached due to    */
2711     if (aiming) {                      /* errors                           */
2712         aiming = FALSE;
2713         Putchar('\n');
2714         FlushStdout();
2715     }
2716 }
2717
2718 /* --------------------------------------------------------------------------
2719  * Error handling:
2720  * ------------------------------------------------------------------------*/
2721
2722 static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
2723     if (printing) {                    /* after successful termination or  */
2724         printing = FALSE;              /* runtime error (e.g. interrupt)   */
2725         Putchar('\n');
2726         if (showStats) {
2727 #define plural(v)   v, (v==1?"":"s")
2728             Printf("(%lu enter%s)\n",plural(numEnters));
2729 #undef plural
2730         }
2731         FlushStdout();
2732         garbageCollect();
2733     }
2734 }
2735
2736 Cell errAssert(l)   /* message to use when raising asserts, etc */
2737 Int l; {
2738   Cell str;
2739   if (currentFile) {
2740     str = mkStr(findText(currentFile));
2741   } else {
2742     str = mkStr(findText(""));
2743   }
2744   return (ap2(nameTangleMessage,str,mkInt(l)));
2745 }
2746
2747 Void errHead(l)                        /* print start of error message     */
2748 Int l; {
2749     failed();                          /* failed to reach target ...       */
2750     stopAnyPrinting();
2751     FPrintf(errorStream,"ERROR");
2752
2753     if (currentFile) {
2754         FPrintf(errorStream," \"%s\"", currentFile);
2755         setLastEdit(currentFile,l);
2756         if (l) FPrintf(errorStream," (line %d)",l);
2757         currentFile = NULL;
2758     }
2759     FPrintf(errorStream,": ");
2760     FFlush(errorStream);
2761 }
2762
2763 Void errFail() {                        /* terminate error message and     */
2764     Putc('\n',errorStream);             /* produce exception to return to  */
2765     FFlush(errorStream);                /* main command loop               */
2766     longjmp(catch_error,1);
2767 }
2768
2769 Void errFail_no_longjmp() {             /* terminate error message but     */
2770     Putc('\n',errorStream);             /* don't produce an exception      */
2771     FFlush(errorStream);
2772 }
2773
2774 Void errAbort() {                       /* altern. form of error handling  */
2775     failed();                           /* used when suitable error message*/
2776     stopAnyPrinting();                  /* has already been printed        */
2777     errFail();
2778 }
2779
2780 Void internal(msg)                      /* handle internal error           */
2781 String msg; {
2782     failed();
2783     stopAnyPrinting();
2784     Printf("INTERNAL ERROR: %s\n",msg);
2785     FlushStdout();
2786 exit(9);
2787     longjmp(catch_error,1);
2788 }
2789
2790 Void fatal(msg)                         /* handle fatal error              */
2791 String msg; {
2792     FlushStdout();
2793     Printf("\nFATAL ERROR: %s\n",msg);
2794     everybody(EXIT);
2795     exit(1);
2796 }
2797
2798
2799 /* --------------------------------------------------------------------------
2800  * Read value from environment variable or registry:
2801  * ------------------------------------------------------------------------*/
2802
2803 String fromEnv(var,def)         /* return value of:                        */
2804 String var;                     /*     environment variable named by var   */
2805 String def; {                   /* or: default value given by def          */
2806     String s = getenv(var);
2807     return (s ? s : def);
2808 }
2809
2810 /* --------------------------------------------------------------------------
2811  * String manipulation routines:
2812  * ------------------------------------------------------------------------*/
2813
2814 static String local strCopy(s)         /* make malloced copy of a string   */
2815 String s; {
2816     if (s && *s) {
2817         char *t, *r;
2818         if ((t=(char *)malloc(strlen(s)+1))==0) {
2819             ERRMSG(0) "String storage space exhausted"
2820             EEND;
2821         }
2822         for (r=t; (*r++ = *s++)!=0; ) {
2823         }
2824         return t;
2825     }
2826     return NULL;
2827 }
2828
2829
2830 /* --------------------------------------------------------------------------
2831  * Compiler output
2832  * We can redirect compiler output (prompts, error messages, etc) by
2833  * tweaking these functions.
2834  * ------------------------------------------------------------------------*/
2835
2836 #ifdef HAVE_STDARG_H
2837 #include <stdarg.h>
2838 #else
2839 #include <varargs.h>
2840 #endif
2841
2842 Void hugsEnableOutput(f)
2843 Bool f; {
2844     disableOutput = !f;
2845 }
2846
2847 #ifdef HAVE_STDARG_H
2848 Void hugsPrintf(const char *fmt, ...) {
2849     va_list ap;                    /* pointer into argument list           */
2850     va_start(ap, fmt);             /* make ap point to first arg after fmt */
2851     if (!disableOutput) {
2852         vprintf(fmt, ap);
2853     } else {
2854     }
2855     va_end(ap);                    /* clean up                             */
2856 }
2857 #else
2858 Void hugsPrintf(fmt, va_alist)
2859 const char *fmt;
2860 va_dcl {
2861     va_list ap;                    /* pointer into argument list           */
2862     va_start(ap);                  /* make ap point to first arg after fmt */
2863     if (!disableOutput) {
2864         vprintf(fmt, ap);
2865     } else {
2866     }
2867     va_end(ap);                    /* clean up                             */
2868 }
2869 #endif
2870
2871 Void hugsPutchar(c)
2872 int c; {
2873     if (!disableOutput) {
2874         putchar(c);
2875     } else {
2876     }
2877 }
2878
2879 Void hugsFlushStdout() {
2880     if (!disableOutput) {
2881         fflush(stdout);
2882     }
2883 }
2884
2885 Void hugsFFlush(fp)
2886 FILE* fp; {
2887     if (!disableOutput) {
2888         fflush(fp);
2889     }
2890 }
2891
2892 #ifdef HAVE_STDARG_H
2893 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2894     va_list ap;
2895     va_start(ap, fmt);
2896     if (!disableOutput) {
2897         vfprintf(fp, fmt, ap);
2898     } else {
2899     }
2900     va_end(ap);
2901 }
2902 #else
2903 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2904 FILE* fp;
2905 const char* fmt;
2906 va_dcl {
2907     va_list ap;
2908     va_start(ap);
2909     if (!disableOutput) {
2910         vfprintf(fp, fmt, ap);
2911     } else {
2912     }
2913     va_end(ap);
2914 }
2915 #endif
2916
2917 Void hugsPutc(c, fp)
2918 int   c;
2919 FILE* fp; {
2920     if (!disableOutput) {
2921         putc(c,fp);
2922     } else {
2923     }
2924 }
2925
2926 /* --------------------------------------------------------------------------
2927  * Send message to each component of system:
2928  * ------------------------------------------------------------------------*/
2929
2930 Void everybody(what)            /* send command `what' to each component of*/
2931 Int what; {                     /* system to respond as appropriate ...    */
2932 #if 0
2933   fprintf ( stderr, "EVERYBODY %d\n", what );
2934 #endif
2935     machdep(what);              /* The order of calling each component is  */
2936     storage(what);              /* important for the PREPREL command       */
2937     substitution(what);
2938     input(what);
2939     translateControl(what);
2940     linkControl(what);
2941     staticAnalysis(what);
2942     deriveControl(what);
2943     typeChecker(what);
2944     compiler(what);
2945     codegen(what);
2946     interfayce(what);
2947
2948     if (what == MARK) {
2949        mark(moduleGraph);
2950        mark(prelModules);
2951        mark(targetModules);
2952        mark(daSccs);
2953        mark(currentModule_failed);
2954     }
2955 }
2956
2957 /*-------------------------------------------------------------------------*/