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