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