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