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