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