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