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