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