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