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.52 $
  13  * $Date: 2000/03/31 04:13:27 $
  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 (mT != textPrelude)
 910          usesT = cons(textPrelude,usesT);
 911       adjList = cons(pair(mT,usesT),adjList);
 912    }
 913
 914    /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
 915       Modify this so that the adjacency list is a list of pointers
 916       back to bits of adjList -- that's what modScc needs.
 917    */
 918    for (t = adjList; nonNull(t); t=tl(t)) {
 919       List adj = NIL;
 920       /* for each elem of the adjacency list ... */
 921       for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
 922          List v;
 923          Text a = hd(u);
 924          /* find the element of adjList whose fst is a */
 925          for (v = adjList; nonNull(v); v=tl(v)) {
 926             assert(isText(a));
 927             assert(isText(fst(hd(v))));
 928             if (fst(hd(v))==a) break;
 929          }
 930          if (isNull(v)) internal("mgFromList");
 931          adj = cons(hd(v),adj);
 932       }
 933       snd(hd(t)) = adj;
 934    }
 935
 936    adjList = modScc ( adjList );
 937    /* adjList is now [ [(module-text, aux-info-field)] ] */
 938
 939    moduleGraph = NIL;
 940
 941    for (t = adjList; nonNull(t); t=tl(t)) {
 942
 943       scc = hd(t);
 944       /* scc :: [ (module-text, aux-info-field) ] */
 945       for (u = scc; nonNull(u); u=tl(u))
 946          hd(u) = mkCon(fst(hd(u)));
 947
 948       /* scc :: [CONID] */
 949       if (length(scc) > 1) {
 950          isRec = TRUE;
 951       } else {
 952          /* singleton module in scc; does it import itself? */
 953          mod = findModule ( textOf(hd(scc)) );
 954          assert(nonNull(mod));
 955          isRec = FALSE;
 956          for (u = module(mod).uses; nonNull(u); u=tl(u))
 957             if (textOf(hd(u))==textOf(hd(scc)))
 958                isRec = TRUE;
 959       }
 960
 961       if (isRec)
 962          moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
 963          moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
 964    }
 965    moduleGraph = reverse(moduleGraph);
 966 }
 967
 968
 969 static List /* of CONID */ getModuleImports ( Cell tree )
 970 {
 971    Cell  te;
 972    List  tes;
 973    ConId use;
 974    List  uses = NIL;
 975    for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
 976       te = hd(tes);
 977       switch(whatIs(te)) {
 978          case M_IMPORT_Q:
 979             use = zfst(unap(M_IMPORT_Q,te));
 980             assert(isCon(use));
 981             if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
 982             break;
 983          case M_IMPORT_UNQ:
 984             use = zfst(unap(M_IMPORT_UNQ,te));
 985             assert(isCon(use));
 986             if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
 987             break;
 988          default:
 989             break;
 990       }
 991    }
 992    return uses;
 993 }
 994
 995
 996 static void processModule ( Module m )
 997 {
 998    Cell  tree;
 999    ConId modNm;
1000    List  topEnts;
1001    List  tes;
1002    Cell  te;
1003    Cell  te2;
1004
1005    tyconDefns     = NIL;
1006    typeInDefns    = NIL;
1007    valDefns       = NIL;
1008    classDefns     = NIL;
1009    instDefns      = NIL;
1010    selDefns       = NIL;
1011    genDefns       = NIL;
1012    unqualImports  = NIL;
1013    foreignImports = NIL;
1014    foreignExports = NIL;
1015    defaultDefns   = NIL;
1016    defaultLine    = 0;
1017    inputExpr      = NIL;
1018
1019    setCurrentFile(m);
1020    startModule(m);
1021    tree = unap(M_MODULE,module(m).tree);
1022    modNm = zfst3(tree);
1023    assert(textOf(modNm)==module(m).text);  /* wrong, but ... */
1024    setExportList(zsnd3(tree));
1025    topEnts = zthd3(tree);
1026
1027    for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
1028       te  = hd(tes);
1029       assert(isGenPair(te));
1030       te2 = snd(te);
1031       switch(whatIs(te)) {
1032          case M_IMPORT_Q:
1033             addQualImport(zfst(te2),zsnd(te2));
1034             break;
1035          case M_IMPORT_UNQ:
1036             addUnqualImport(zfst(te2),zsnd(te2));
1037             break;
1038          case M_TYCON:
1039             tyconDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1040             break;
1041          case M_CLASS:
1042             classDefn(zsel14(te2),zsel24(te2),zsel34(te2),zsel44(te2));
1043             break;
1044          case M_INST:
1045             instDefn(zfst3(te2),zsnd3(te2),zthd3(te2));
1046             break;
1047          case M_DEFAULT:
1048             defaultDefn(zfst(te2),zsnd(te2));
1049             break;
1050          case M_FOREIGN_IM:
1051             foreignImport(zsel15(te2),zsel25(te2),zsel35(te2),
1052                           zsel45(te2),zsel55(te2));
1053             break;
1054          case M_FOREIGN_EX:
1055             foreignExport(zsel15(te2),zsel25(te2),zsel35(te2),
1056                           zsel45(te2),zsel55(te2));
1057          case M_VALUE:
1058             valDefns = cons(te2,valDefns);
1059             break;
1060          default:
1061             internal("processModule");
1062       }
1063    }
1064    checkDefns(m);
1065    typeCheckDefns();
1066    compileDefns();
1067 }
1068
1069
1070 static Module parseModuleOrInterface ( ConId mc,
1071                                        List renewFromSource,
1072                                        List renewFromObject )
1073 {
1074    /* Allocate a module-table entry. */
1075    /* Parse the entity and fill in the .tree and .uses entries. */
1076    String path;
1077    String sExt;
1078    Bool sAvail; Time sTime; Long sSize;
1079    Bool iAvail; Time iTime; Long iSize;
1080    Bool oAvail; Time oTime; Long oSize;
1081    Bool ok;
1082    Bool useSource;
1083    char name[10000];
1084
1085    Text   mt  = textOf(mc);
1086    Module mod = findModule ( mt );
1087
1088    /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
1089                 textToStr(mt),mod); */
1090    if (nonNull(mod) && !module(mod).fake)
1091       internal("parseModuleOrInterface");
1092    if (nonNull(mod))
1093       module(mod).fake = FALSE;
1094
1095    if (isNull(mod))
1096       mod = newModule(mt);
1097
1098    /* This call malloc-ates path; we should deallocate it. */
1099    ok = findFilesForModule (
1100            textToStr(module(mod).text),
1101            &path,
1102            &sExt,
1103            &sAvail, &sTime, &sSize,
1104            &iAvail, &iTime, &iSize,
1105            &oAvail, &oTime, &oSize
1106         );
1107
1108    if (!ok) goto cant_find;
1109    if (!sAvail && !(iAvail && oAvail)) goto cant_find;
1110
1111    /* Find out whether to use source or object. */
1112    if (varIsMember(mt,renewFromSource)) {
1113       if (!sAvail) goto cant_find;
1114       useSource = TRUE;
1115    } else
1116    if (varIsMember(mt,renewFromObject)) {
1117       if (!(oAvail && iAvail)) goto cant_find;
1118       useSource = FALSE;
1119    } else
1120    if (sAvail && !(iAvail && oAvail)) {
1121       useSource = TRUE;
1122    } else
1123    if (!sAvail && (iAvail && oAvail)) {
1124       useSource = FALSE;
1125    } else {
1126       useSource = firstTimeIsLater(sTime,whicheverIsLater(oTime,iTime));
1127    }
1128
1129    if (!combined && !sAvail) goto cant_find;
1130    if (!combined) useSource = TRUE;
1131
1132    module(mod).srcExt = findText(sExt);
1133    setCurrentFile(mod);
1134
1135    /* Actually do the parsing. */
1136    if (useSource) {
1137       strcpy(name, path);
1138       strcat(name, textToStr(mt));
1139       strcat(name, sExt);
1140       module(mod).tree      = parseModule(name,sSize);
1141       module(mod).uses      = getModuleImports(module(mod).tree);
1142       module(mod).fromSrc   = TRUE;
1143       module(mod).lastStamp = sTime;
1144    } else {
1145       strcpy(name, path);
1146       strcat(name, textToStr(mt));
1147       strcat(name, DLL_ENDING);
1148       module(mod).objName = findText(name);
1149       module(mod).objSize = oSize;
1150       strcpy(name, path);
1151       strcat(name, textToStr(mt));
1152       strcat(name, ".u_hi");
1153       module(mod).tree      = parseInterface(name,iSize);
1154       module(mod).uses      = getInterfaceImports(module(mod).tree);
1155       module(mod).fromSrc   = FALSE;
1156       module(mod).lastStamp = whicheverIsLater(oTime,iTime);
1157    }
1158
1159    if (path) free(path);
1160    return mod;
1161
1162   cant_find:
1163    if (path) free(path);
1164    ERRMSG(0)
1165       "Can't find source or object+interface for module \"%s\"",
1166       textToStr(mt)
1167    EEND;
1168 }
1169
1170
1171 static void tryLoadGroup ( Cell grp )
1172 {
1173    Module m;
1174    List   t;
1175    switch (whatIs(grp)) {
1176       case GRP_NONREC:
1177          m = findModule(textOf(snd(grp)));
1178          assert(nonNull(m));
1179          if (module(m).fromSrc) {
1180             processModule ( m );
1181          } else {
1182             processInterfaces ( singleton(snd(grp)) );
1183          }
1184          break;
1185       case GRP_REC:
1186          for (t = snd(grp); nonNull(t); t=tl(t)) {
1187             m = findModule(textOf(hd(t)));
1188             assert(nonNull(m));
1189             if (module(m).fromSrc) {
1190                ERRMSG(0) "Source module \"%s\" imports itself recursively",
1191                          textToStr(textOf(hd(t)))
1192                EEND;
1193             }
1194          }
1195          processInterfaces ( snd(grp) );
1196          break;
1197       default:
1198          internal("tryLoadGroup");
1199    }
1200 }
1201
1202
1203 static void fallBackToPrelModules ( void )
1204 {
1205    Module m;
1206    for (m = MODULE_BASE_ADDR;
1207         m < MODULE_BASE_ADDR+tabModuleSz; m++)
1208       if (module(m).inUse
1209           && !varIsMember(module(m).text, prelModules))
1210          nukeModule(m);
1211 }
1212
1213
1214 /* This function catches exceptions in most of the system.
1215    So it's only ok for procedures called from this one
1216    to do EENDs (ie, write error messages).  Others should use
1217    EEND_NO_LONGJMP.
1218 */
1219 static void achieveTargetModules ( void )
1220 {
1221    volatile List   ood;
1222    volatile List   modgList;
1223    volatile List   renewFromSource;
1224    volatile List   renewFromObject;
1225    volatile List   t;
1226    volatile Module mod;
1227    volatile Bool   ok;
1228
1229    String path = NULL;
1230    String sExt = NULL;
1231    Bool sAvail; Time sTime; Long sSize;
1232    Bool iAvail; Time iTime; Long iSize;
1233    Bool oAvail; Time oTime; Long oSize;
1234
1235    volatile Time oisTime;
1236    volatile Time oiTime;
1237    volatile Bool sourceIsLatest;
1238    volatile Bool out_of_date;
1239    volatile List ood_new;
1240    volatile List us;
1241    volatile List modgList_new;
1242    volatile List parsedButNotLoaded;
1243    volatile List toChase;
1244    volatile List trans_cl;
1245    volatile List trans_cl_new;
1246    volatile List u;
1247    volatile List mg;
1248    volatile List mg2;
1249    volatile Cell grp;
1250    volatile List badMods;
1251
1252    setBreakAction ( HugsIgnoreBreak );
1253
1254    /* First, examine timestamps to find out which modules are
1255       out of date with respect to the source/interface/object files.
1256    */
1257    ood      = NIL;
1258    modgList = listFromMG();
1259
1260    renewFromSource = renewFromObject = NIL;
1261
1262    for (t = modgList; nonNull(t); t=tl(t)) {
1263
1264       if (varIsMember(textOf(hd(t)),prelModules))
1265          continue;
1266
1267       mod = findModule(textOf(hd(t)));
1268       if (isNull(mod)) internal("achieveTargetSet(1)");
1269
1270       ok = findFilesForModule (
1271               textToStr(module(mod).text),
1272               &path,
1273               &sExt,
1274               &sAvail, &sTime, &sSize,
1275               &iAvail, &iTime, &iSize,
1276               &oAvail, &oTime, &oSize
1277            );
1278       if (!combined && !sAvail) ok = FALSE;
1279       if (!ok) {
1280          fallBackToPrelModules();
1281          ERRMSG(0)
1282             "Can't find source or object+interface for module \"%s\"",
1283             textToStr(module(mod).text)
1284          EEND_NO_LONGJMP;
1285          if (path) free(path);
1286          return;
1287       }
1288       /* findFilesForModule should enforce this */
1289       if (!(sAvail || (oAvail && iAvail)))
1290          internal("achieveTargetSet(2)");
1291
1292       if (!combined) {
1293          oisTime = sTime;
1294          sourceIsLatest = TRUE;
1295       } else {
1296          if (sAvail && !(oAvail && iAvail)) {
1297             oisTime = sTime;
1298             sourceIsLatest = TRUE;
1299          } else
1300          if (!sAvail && (oAvail && iAvail)) {
1301             oisTime = whicheverIsLater(oTime,iTime);
1302             sourceIsLatest = FALSE;
1303          } else
1304          if (sAvail && (oAvail && iAvail)) {
1305             oisTime = whicheverIsLater(oTime,iTime);
1306             if (firstTimeIsLater(sTime,oisTime)) {
1307                oisTime = sTime;
1308                sourceIsLatest = TRUE;
1309             } else {
1310                sourceIsLatest = FALSE;
1311             }
1312          } else {
1313             internal("achieveTargetSet(1a)");
1314          }
1315       }
1316
1317       out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
1318       if (out_of_date) {
1319          assert(!varIsMember(textOf(hd(t)),ood));
1320          ood = cons(hd(t),ood);
1321          if (sourceIsLatest)
1322             renewFromSource = cons(hd(t),renewFromSource); else
1323             renewFromObject = cons(hd(t),renewFromObject);
1324       }
1325
1326       if (path) { free(path); path = NULL; };
1327    }
1328
1329    /* Second, form a simplistic transitive closure of the out-of-date
1330       modules: a module is out of date if it imports an out-of-date
1331       module.
1332    */
1333    while (1) {
1334       ood_new = NIL;
1335       for (t = modgList; nonNull(t); t=tl(t)) {
1336          mod = findModule(textOf(hd(t)));
1337          assert(nonNull(mod));
1338          for (us = module(mod).uses; nonNull(us); us=tl(us))
1339             if (varIsMember(textOf(hd(us)),ood))
1340                break;
1341          if (nonNull(us)) {
1342             if (varIsMember(textOf(hd(t)),prelModules))
1343                Printf ( "warning: prelude module \"%s\" is out-of-date\n",
1344                         textToStr(textOf(hd(t))) );
1345             else
1346                if (!varIsMember(textOf(hd(t)),ood_new) &&
1347                    !varIsMember(textOf(hd(t)),ood))
1348                   ood_new = cons(hd(t),ood_new);
1349          }
1350       }
1351       if (isNull(ood_new)) break;
1352       ood = appendOnto(ood_new,ood);
1353    }
1354
1355    /* Now ood holds the entire set of modules which are out-of-date.
1356       Throw them out of the system, yielding a "reduced system",
1357       in which the remaining modules are in-date.
1358    */
1359    for (t = ood; nonNull(t); t=tl(t)) {
1360       mod = findModule(textOf(hd(t)));
1361       assert(nonNull(mod));
1362       nukeModule(mod);
1363    }
1364    modgList_new = NIL;
1365    for (t = modgList; nonNull(t); t=tl(t))
1366       if (!varIsMember(textOf(hd(t)),ood))
1367          modgList_new = cons(hd(t),modgList_new);
1368    modgList = modgList_new;
1369
1370    /* Update the module group list to reflect the reduced system.
1371       We do this so that if the following parsing phases fail, we can
1372       safely fall back to the reduced system.
1373    */
1374    mgFromList ( modgList );
1375
1376    /* Parse modules/interfaces, collecting parse trees and chasing
1377       imports, starting from the target set.
1378    */
1379    parsedButNotLoaded = NIL;
1380    toChase = dupList(targetModules);
1381
1382    while (nonNull(toChase)) {
1383       ConId mc = hd(toChase);
1384       toChase  = tl(toChase);
1385       if (!varIsMember(textOf(mc),modgList)
1386           && !varIsMember(textOf(mc),parsedButNotLoaded)) {
1387
1388          setBreakAction ( HugsLongjmpOnBreak );
1389          if (setjmp(catch_error)==0) {
1390             /* try this; it may throw an exception */
1391             mod = parseModuleOrInterface (
1392                      mc, renewFromSource, renewFromObject );
1393          } else {
1394             /* here's the exception handler, if parsing fails */
1395             /* A parse error (or similar).  Clean up and abort. */
1396             setBreakAction ( HugsIgnoreBreak );
1397             mod = findModule(textOf(mc));
1398             if (nonNull(mod)) nukeModule(mod);
1399             for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
1400                mod = findModule(textOf(hd(t)));
1401                assert(nonNull(mod));
1402                if (nonNull(mod)) nukeModule(mod);
1403             }
1404             return;
1405             /* end of the exception handler */
1406          }
1407          setBreakAction ( HugsIgnoreBreak );
1408
1409          parsedButNotLoaded = cons(mc, parsedButNotLoaded);
1410          toChase = dupOnto(module(mod).uses,toChase);
1411       }
1412    }
1413
1414    modgList = dupOnto(parsedButNotLoaded, modgList);
1415
1416    /* We successfully parsed all modules reachable from the target
1417       set which were not part of the reduced system.  However, there
1418       may be modules in the reduced system which are not reachable from
1419       the target set.  We detect these now by building the transitive
1420       closure of the target set, and nuking modules in the reduced
1421       system which are not part of that closure.
1422    */
1423    trans_cl = dupList(targetModules);
1424    while (1) {
1425       trans_cl_new = NIL;
1426       for (t = trans_cl; nonNull(t); t=tl(t)) {
1427          mod = findModule(textOf(hd(t)));
1428          assert(nonNull(mod));
1429          for (u = module(mod).uses; nonNull(u); u=tl(u))
1430             if (!varIsMember(textOf(hd(u)),trans_cl)
1431                 && !varIsMember(textOf(hd(u)),trans_cl_new)
1432                 && !varIsMember(textOf(hd(u)),prelModules))
1433                trans_cl_new = cons(hd(u),trans_cl_new);
1434       }
1435       if (isNull(trans_cl_new)) break;
1436       trans_cl = appendOnto(trans_cl_new,trans_cl);
1437    }
1438    modgList_new = NIL;
1439    for (t = modgList; nonNull(t); t=tl(t)) {
1440       if (varIsMember(textOf(hd(t)),trans_cl)) {
1441          modgList_new = cons(hd(t),modgList_new);
1442       } else {
1443          mod = findModule(textOf(hd(t)));
1444          assert(nonNull(mod));
1445          nukeModule(mod);
1446       }
1447    }
1448    modgList = modgList_new;
1449
1450    /* Now, the module symbol tables hold exactly the set of
1451       modules reachable from the target set, and modgList holds
1452       their names.   Calculate the scc-ified module graph,
1453       since we need that to guide the next stage, that of
1454       Actually Loading the modules.
1455
1456       If no errors occur, moduleGraph will reflect the final graph
1457       loaded.  If an error occurs loading a group, we nuke
1458       that group, truncate the moduleGraph just prior to that
1459       group, and exit.  That leaves the system having successfully
1460       loaded all groups prior to the one which failed.
1461    */
1462    mgFromList ( modgList );
1463
1464    for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
1465       grp = hd(mg);
1466
1467       if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
1468                        parsedButNotLoaded)) continue;
1469
1470       setBreakAction ( HugsLongjmpOnBreak );
1471       if (setjmp(catch_error)==0) {
1472          /* try this; it may throw an exception */
1473          tryLoadGroup(grp);
1474       } else {
1475          /* here's the exception handler, if static/typecheck etc fails */
1476          /* nuke the entire rest (ie, the unloaded part)
1477             of the module graph */
1478          setBreakAction ( HugsIgnoreBreak );
1479          badMods = listFromSpecifiedMG ( mg );
1480          for (t = badMods; nonNull(t); t=tl(t)) {
1481             mod = findModule(textOf(hd(t)));
1482             if (nonNull(mod)) nukeModule(mod);
1483          }
1484          /* truncate the module graph just prior to this group. */
1485          mg2 = NIL;
1486          mg = moduleGraph;
1487          while (TRUE) {
1488             if (isNull(mg)) break;
1489             if (hd(mg) == grp) break;
1490             mg2 = cons ( hd(mg), mg2 );
1491             mg = tl(mg);
1492          }
1493          moduleGraph = reverse(mg2);
1494          return;
1495          /* end of the exception handler */
1496       }
1497       setBreakAction ( HugsIgnoreBreak );
1498    }
1499
1500    /* Err .. I think that's it.  If we get here, we've successfully
1501       achieved the target set.  Phew!
1502    */
1503    setBreakAction ( HugsIgnoreBreak );
1504 }
1505
1506
1507 static Bool loadThePrelude ( void )
1508 {
1509    Bool ok;
1510    ConId conPrelude;
1511    ConId conPrelHugs;
1512    moduleGraph = prelModules = NIL;
1513
1514    if (combined) {
1515       conPrelude    = mkCon(findText("Prelude"));
1516       conPrelHugs   = mkCon(findText("PrelHugs"));
1517       targetModules = doubleton(conPrelude,conPrelHugs);
1518       achieveTargetModules();
1519       ok = elemMG(conPrelude) && elemMG(conPrelHugs);
1520    } else {
1521       conPrelude    = mkCon(findText("Prelude"));
1522       targetModules = singleton(conPrelude);
1523       achieveTargetModules();
1524       ok = elemMG(conPrelude);
1525    }
1526
1527    if (ok) prelModules = listFromMG();
1528    return ok;
1529 }
1530
1531
1532 static void refreshActions ( ConId nextCurrMod )
1533 {
1534    ConId tryFor = mkCon(module(currentModule).text);
1535    achieveTargetModules();
1536    if (nonNull(nextCurrMod))
1537       tryFor = nextCurrMod;
1538    if (!elemMG(tryFor))
1539       tryFor = selectLatestMG();
1540    /* combined mode kludge, to get Prelude rather than PrelHugs */
1541    if (combined && textOf(tryFor)==findText("PrelHugs"))
1542       tryFor = mkCon(findText("Prelude"));
1543
1544    setCurrModule ( findModule(textOf(tryFor)) );
1545    Printf("Hugs session for:\n");
1546    ppMG();
1547 }
1548
1549
1550 static void addActions ( List extraModules /* :: [CONID] */ )
1551 {
1552    List t;
1553    for (t = extraModules; nonNull(t); t=tl(t)) {
1554       ConId extra = hd(t);
1555       if (!varIsMember(textOf(extra),targetModules))
1556          targetModules = cons(extra,targetModules);
1557    }
1558    refreshActions ( isNull(extraModules)
1559                     ? NIL
1560                     : hd(reverse(extraModules))
1561                   );
1562 }
1563
1564
1565 static void loadActions ( List loadModules /* :: [CONID] */ )
1566 {
1567    List t;
1568    targetModules = dupList ( prelModules );
1569
1570    for (t = loadModules; nonNull(t); t=tl(t)) {
1571       ConId load = hd(t);
1572       if (!varIsMember(textOf(load),targetModules))
1573          targetModules = cons(load,targetModules);
1574    }
1575    refreshActions ( isNull(loadModules)
1576                     ? NIL
1577                     : hd(reverse(loadModules))
1578                   );
1579 }
1580
1581
1582 /* --------------------------------------------------------------------------
1583  * Access to external editor:
1584  * ------------------------------------------------------------------------*/
1585
1586 /* ToDo: All this editor stuff needs fixing. */
1587
1588 static Void local editor() {            /* interpreter-editor interface    */
1589 #if 0
1590     String newFile  = readFilename();
1591     if (newFile) {
1592         setLastEdit(newFile,0);
1593         if (readFilename()) {
1594             ERRMSG(0) "Multiple filenames not permitted"
1595             EEND;
1596         }
1597     }
1598     runEditor();
1599 #endif
1600 }
1601
1602 static Void local find() {              /* edit file containing definition */
1603 #if 0
1604 ToDo: Fix!
1605     String nm = readFilename();         /* of specified name               */
1606     if (!nm) {
1607         ERRMSG(0) "No name specified"
1608         EEND;
1609     }
1610     else if (readFilename()) {
1611         ERRMSG(0) "Multiple names not permitted"
1612         EEND;
1613     }
1614     else {
1615         Text t;
1616         Cell c;
1617         setCurrModule(findEvalModule());
1618         startNewScript(0);
1619         if (nonNull(c=findTycon(t=findText(nm)))) {
1620             if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1621                 readScripts(N_PRELUDE_SCRIPTS);
1622             }
1623         } else if (nonNull(c=findName(t))) {
1624             if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1625                 readScripts(N_PRELUDE_SCRIPTS);
1626             }
1627         } else {
1628             ERRMSG(0) "No current definition for name \"%s\"", nm
1629             EEND;
1630         }
1631     }
1632 #endif
1633 }
1634
1635 static Void local runEditor() {         /* run editor on script lastEdit   */
1636 #if 0
1637     if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine              */
1638         readScripts(N_PRELUDE_SCRIPTS);
1639 #endif
1640 }
1641
1642 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1643 String fname;
1644 Int    line; {
1645 #if 0
1646     if (lastEdit)
1647         free(lastEdit);
1648     lastEdit = strCopy(fname);
1649     lastEdLine = line;
1650 #endif
1651 }
1652
1653 /* --------------------------------------------------------------------------
1654  * Read and evaluate an expression:
1655  * ------------------------------------------------------------------------*/
1656
1657 static Void setModule ( void ) {
1658                               /*set module in which to evaluate expressions*/
1659    Module m;
1660    ConId  mc = NIL;
1661    String s  = readFilename();
1662    if (!s) {
1663       mc = selectLatestMG();
1664       if (combined && textOf(mc)==findText("PrelHugs"))
1665          mc = mkCon(findText("Prelude"));
1666       m = findModule(textOf(mc));
1667       assert(nonNull(m));
1668    } else {
1669       m = findModule(findText(s));
1670       if (isNull(m)) {
1671          ERRMSG(0) "Cannot find module \"%s\"", s
1672          EEND_NO_LONGJMP;
1673          return;
1674       }
1675    }
1676    setCurrModule(m);
1677 }
1678
1679 static Module allocEvalModule ( void )
1680 {
1681    Module evalMod = newModule( findText("_Eval_Module_") );
1682    module(evalMod).names   = module(currentModule).names;
1683    module(evalMod).tycons  = module(currentModule).tycons;
1684    module(evalMod).classes = module(currentModule).classes;
1685    module(evalMod).qualImports
1686      = singleton(pair(mkCon(textPrelude),modulePrelude));
1687    return evalMod;
1688 }
1689
1690 static Void local evaluator() {        /* evaluate expr and print value    */
1691     volatile Type   type;
1692     volatile Type   bd;
1693     volatile Kinds  ks      = NIL;
1694     volatile Module evalMod = allocEvalModule();
1695     volatile Module currMod = currentModule;
1696     setCurrModule(evalMod);
1697     currentFile = NULL;
1698
1699     defaultDefns = combined ? stdDefaults : evalDefaults;
1700
1701     setBreakAction ( HugsLongjmpOnBreak );
1702     if (setjmp(catch_error)==0) {
1703        /* try this */
1704        parseExp();
1705        checkExp();
1706        type = typeCheckExp(TRUE);
1707     } else {
1708        /* if an exception happens, we arrive here */
1709        setBreakAction ( HugsIgnoreBreak );
1710        goto cleanup_and_return;
1711     }
1712
1713     setBreakAction ( HugsIgnoreBreak );
1714     if (isPolyType(type)) {
1715         ks = polySigOf(type);
1716         bd = monotypeOf(type);
1717     }
1718     else
1719         bd = type;
1720
1721     if (whatIs(bd)==QUAL) {
1722        ERRMSG(0) "Unresolved overloading" ETHEN
1723        ERRTEXT   "\n*** Type       : "    ETHEN ERRTYPE(type);
1724        ERRTEXT   "\n*** Expression : "    ETHEN ERREXPR(inputExpr);
1725        ERRTEXT   "\n"
1726        EEND_NO_LONGJMP;
1727        goto cleanup_and_return;
1728     }
1729
1730 #if 1
1731     if (isProgType(ks,bd)) {
1732         inputExpr = ap(nameRunIO_toplevel,inputExpr);
1733         evalExp();
1734         Putchar('\n');
1735     } else {
1736         Cell d = provePred(ks,NIL,ap(classShow,bd));
1737         if (isNull(d)) {
1738            ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1739            ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
1740            ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
1741            ERRTEXT   "\n"
1742            EEND_NO_LONGJMP;
1743            goto cleanup_and_return;
1744         }
1745         inputExpr = ap2(nameShow,           d,inputExpr);
1746         inputExpr = ap (namePutStr,         inputExpr);
1747         inputExpr = ap (nameRunIO_toplevel, inputExpr);
1748
1749         evalExp(); printf("\n");
1750         if (addType) {
1751             printf(" :: ");
1752             printType(stdout,type);
1753             Putchar('\n');
1754         }
1755     }
1756
1757 #else
1758
1759    printf ( "result type is " );
1760    printType ( stdout, type );
1761    printf ( "\n" );
1762    evalExp();
1763    printf ( "\n" );
1764
1765 #endif
1766
1767   cleanup_and_return:
1768    setBreakAction ( HugsIgnoreBreak );
1769    nukeModule(evalMod);
1770    setCurrModule(currMod);
1771    setCurrentFile(currMod);
1772 }
1773
1774
1775
1776 /* --------------------------------------------------------------------------
1777  * Print type of input expression:
1778  * ------------------------------------------------------------------------*/
1779
1780 static Void showtype ( void ) {        /* print type of expression (if any)*/
1781
1782     volatile Cell   type;
1783     volatile Module evalMod = allocEvalModule();
1784     volatile Module currMod = currentModule;
1785     setCurrModule(evalMod);
1786
1787     if (setjmp(catch_error)==0) {
1788        /* try this */
1789        parseExp();
1790        checkExp();
1791        defaultDefns = evalDefaults;
1792        type = typeCheckExp(FALSE);
1793        printExp(stdout,inputExpr);
1794        Printf(" :: ");
1795        printType(stdout,type);
1796        Putchar('\n');
1797     } else {
1798        /* if an exception happens, we arrive here */
1799     }
1800
1801     nukeModule(evalMod);
1802     setCurrModule(currMod);
1803 }
1804
1805
1806 static Void local browseit(mod,t,all)
1807 Module mod;
1808 String t;
1809 Bool all; {
1810     if (nonNull(mod)) {
1811         Cell cs;
1812         if (nonNull(t))
1813             Printf("module %s where\n",textToStr(module(mod).text));
1814         for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1815             Name nm = hd(cs);
1816             /* only look at things defined in this module,
1817                unless `all' flag is set */
1818             if (all || name(nm).mod == mod) {
1819                 /* unwanted artifacts, like lambda lifted values,
1820                    are in the list of names, but have no types */
1821                 if (nonNull(name(nm).type)) {
1822                     printExp(stdout,nm);
1823                     Printf(" :: ");
1824                     printType(stdout,name(nm).type);
1825                     if (isCfun(nm)) {
1826                         Printf("  -- data constructor");
1827                     } else if (isMfun(nm)) {
1828                         Printf("  -- class member");
1829                     } else if (isSfun(nm)) {
1830                         Printf("  -- selector function");
1831                     }
1832                     Printf("\n");
1833                 }
1834             }
1835         }
1836     } else {
1837       if (isNull(mod)) {
1838         Printf("Unknown module %s\n",t);
1839       }
1840     }
1841 }
1842
1843 static Void local browse() {            /* browse modules                  */
1844     Int    count = 0;                   /* or give menu of commands        */
1845     String s;
1846     Bool all = FALSE;
1847
1848     for (; (s=readFilename())!=0; count++)
1849         if (strcmp(s,"all") == 0) {
1850             all = TRUE;
1851             --count;
1852         } else
1853             browseit(findModule(findText(s)),s,all);
1854     if (count == 0) {
1855         browseit(currentModule,NULL,all);
1856     }
1857 }
1858
1859 #if EXPLAIN_INSTANCE_RESOLUTION
1860 static Void local xplain() {         /* print type of expression (if any)*/
1861     Cell d;
1862     Bool sir = showInstRes;
1863
1864     setCurrModule(findEvalModule());
1865     startNewScript(0);                 /* Enables recovery of storage      */
1866                                        /* allocated during evaluation      */
1867     parseContext();
1868     checkContext();
1869     showInstRes = TRUE;
1870     d = provePred(NIL,NIL,hd(inputContext));
1871     if (isNull(d)) {
1872         fprintf(stdout, "not Sat\n");
1873     } else {
1874         fprintf(stdout, "Sat\n");
1875     }
1876     showInstRes = sir;
1877 }
1878 #endif
1879
1880 /* --------------------------------------------------------------------------
1881  * Enhanced help system:  print current list of scripts or give information
1882  * about an object.
1883  * ------------------------------------------------------------------------*/
1884
1885 static String local objToStr(m,c)
1886 Module m;
1887 Cell   c; {
1888 #if 1 || DISPLAY_QUANTIFIERS
1889     static char newVar[60];
1890     switch (whatIs(c)) {
1891         case NAME  : if (m == name(c).mod) {
1892                          sprintf(newVar,"%s", textToStr(name(c).text));
1893                      } else {
1894                          sprintf(newVar,"%s.%s",
1895                                         textToStr(module(name(c).mod).text),
1896                                         textToStr(name(c).text));
1897                      }
1898                      break;
1899
1900         case TYCON : if (m == tycon(c).mod) {
1901                          sprintf(newVar,"%s", textToStr(tycon(c).text));
1902                      } else {
1903                          sprintf(newVar,"%s.%s",
1904                                         textToStr(module(tycon(c).mod).text),
1905                                         textToStr(tycon(c).text));
1906                      }
1907                      break;
1908
1909         case CLASS : if (m == cclass(c).mod) {
1910                          sprintf(newVar,"%s", textToStr(cclass(c).text));
1911                      } else {
1912                          sprintf(newVar,"%s.%s",
1913                                         textToStr(module(cclass(c).mod).text),
1914                                         textToStr(cclass(c).text));
1915                      }
1916                      break;
1917
1918         default    : internal("objToStr");
1919     }
1920     return newVar;
1921 #else
1922     static char newVar[33];
1923     switch (whatIs(c)) {
1924         case NAME  : sprintf(newVar,"%s", textToStr(name(c).text));
1925                      break;
1926
1927         case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1928                      break;
1929
1930         case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1931                      break;
1932
1933         default    : internal("objToStr");
1934     }
1935     return newVar;
1936 #endif
1937 }
1938
1939 extern Name nameHw;
1940
1941 static Void dumpStg ( void )
1942 {
1943    String s;
1944    Int i;
1945 #if 0
1946    Whats this for?
1947    setCurrModule(findEvalModule());
1948    startNewScript(0);
1949 #endif
1950    s = readFilename();
1951
1952    /* request to locate a symbol by name */
1953    if (s && (*s == '?')) {
1954       Text t = findText(s+1);
1955       locateSymbolByName(t);
1956       return;
1957    }
1958
1959    /* request to dump a bit of the heap */
1960    if (s && (*s == '-' || isdigit(*s))) {
1961       int i = atoi(s);
1962       print(i,100);
1963       printf("\n");
1964       return;
1965    }
1966
1967    /* request to dump a symbol table entry */
1968    if (!s
1969        || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
1970        || !isdigit(s[1])) {
1971       fprintf(stderr, ":d -- bad request `%s'\n", s );
1972       return;
1973    }
1974    i = atoi(s+1);
1975    switch (*s) {
1976       case 't': dumpTycon(i); break;
1977       case 'n': dumpName(i); break;
1978       case 'c': dumpClass(i); break;
1979       case 'i': dumpInst(i); break;
1980       default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
1981    }
1982 }
1983
1984
1985 #if 0
1986 static Void local dumpStg( void ) {       /* print STG stuff                 */
1987     String s;
1988     Text   t;
1989     Name   n;
1990     Int    i;
1991     Cell   v;                           /* really StgVar */
1992     setCurrModule(findEvalModule());
1993     startNewScript(0);
1994     for (; (s=readFilename())!=0;) {
1995         t = findText(s);
1996         v = n = NIL;
1997         /* find the name while ignoring module scopes */
1998         for (i=NAMEMIN; i<nameHw; i++)
1999            if (name(i).text == t) n = i;
2000
2001         /* perhaps it's an "idNNNNNN" thing? */
2002         if (isNull(n) &&
2003             strlen(s) >= 3 &&
2004             s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2005            v = 0;
2006            i = 2;
2007            while (isdigit(s[i])) {
2008               v = v * 10 + (s[i]-'0');
2009               i++;
2010            }
2011            v = -v;
2012            n = nameFromStgVar(v);
2013         }
2014
2015         if (isNull(n) && whatIs(v)==STGVAR) {
2016            Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2017            printStg(stderr, v );
2018         } else
2019         if (isNull(n)) {
2020            Printf ( "Unknown reference `%s'\n", s );
2021         } else
2022         if (!isName(n)) {
2023            Printf ( "Not a Name: `%s'\n", s );
2024         } else
2025         if (isNull(name(n).stgVar)) {
2026            Printf ( "Doesn't have a STG tree: %s\n", s );
2027         } else {
2028            Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2029            printStg(stderr, name(n).stgVar);
2030         }
2031     }
2032 }
2033 #endif
2034
2035 static Void local info() {              /* describe objects                */
2036     Int    count = 0;                   /* or give menu of commands        */
2037     String s;
2038
2039     for (; (s=readFilename())!=0; count++) {
2040         describe(findText(s));
2041     }
2042     if (count == 0) {
2043        /* whatScripts(); */
2044     }
2045 }
2046
2047
2048 static Void local describe(t)           /* describe an object              */
2049 Text t; {
2050     Tycon  tc  = findTycon(t);
2051     Class  cl  = findClass(t);
2052     Name   nm  = findName(t);
2053
2054     if (nonNull(tc)) {                  /* as a type constructor           */
2055         Type t = tc;
2056         Int  i;
2057         Inst in;
2058         for (i=0; i<tycon(tc).arity; ++i) {
2059             t = ap(t,mkOffset(i));
2060         }
2061         Printf("-- type constructor");
2062         if (kindExpert) {
2063             Printf(" with kind ");
2064             printKind(stdout,tycon(tc).kind);
2065         }
2066         Putchar('\n');
2067         switch (tycon(tc).what) {
2068             case SYNONYM      : Printf("type ");
2069                                 printType(stdout,t);
2070                                 Printf(" = ");
2071                                 printType(stdout,tycon(tc).defn);
2072                                 break;
2073
2074             case NEWTYPE      :
2075             case DATATYPE     : {   List cs = tycon(tc).defn;
2076                                     if (tycon(tc).what==DATATYPE) {
2077                                         Printf("data ");
2078                                     } else {
2079                                         Printf("newtype ");
2080                                     }
2081                                     printType(stdout,t);
2082                                     Putchar('\n');
2083                                     mapProc(printSyntax,cs);
2084                                     if (hasCfun(cs)) {
2085                                         Printf("\n-- constructors:");
2086                                     }
2087                                     for (; hasCfun(cs); cs=tl(cs)) {
2088                                         Putchar('\n');
2089                                         printExp(stdout,hd(cs));
2090                                         Printf(" :: ");
2091                                         printType(stdout,name(hd(cs)).type);
2092                                     }
2093                                     if (nonNull(cs)) {
2094                                         Printf("\n-- selectors:");
2095                                     }
2096                                     for (; nonNull(cs); cs=tl(cs)) {
2097                                         Putchar('\n');
2098                                         printExp(stdout,hd(cs));
2099                                         Printf(" :: ");
2100                                         printType(stdout,name(hd(cs)).type);
2101                                     }
2102                                 }
2103                                 break;
2104
2105             case RESTRICTSYN  : Printf("type ");
2106                                 printType(stdout,t);
2107                                 Printf(" = <restricted>");
2108                                 break;
2109         }
2110         Putchar('\n');
2111         if (nonNull(in=findFirstInst(tc))) {
2112             Printf("\n-- instances:\n");
2113             do {
2114                 showInst(in);
2115                 in = findNextInst(tc,in);
2116             } while (nonNull(in));
2117         }
2118         Putchar('\n');
2119     }
2120
2121     if (nonNull(cl)) {                  /* as a class                      */
2122         List  ins = cclass(cl).instances;
2123         Kinds ks  = cclass(cl).kinds;
2124         if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2125             Printf("-- type class");
2126         } else {
2127             Printf("-- constructor class");
2128             if (kindExpert) {
2129                 Printf(" with arity ");
2130                 printKinds(stdout,ks);
2131             }
2132         }
2133         Putchar('\n');
2134         mapProc(printSyntax,cclass(cl).members);
2135         Printf("class ");
2136         if (nonNull(cclass(cl).supers)) {
2137             printContext(stdout,cclass(cl).supers);
2138             Printf(" => ");
2139         }
2140         printPred(stdout,cclass(cl).head);
2141
2142         if (nonNull(cclass(cl).fds)) {
2143             List   fds = cclass(cl).fds;
2144             String pre = " | ";
2145             for (; nonNull(fds); fds=tl(fds)) {
2146                 Printf(pre);
2147                 printFD(stdout,hd(fds));
2148                 pre = ", ";
2149             }
2150         }
2151
2152         if (nonNull(cclass(cl).members)) {
2153             List ms = cclass(cl).members;
2154             Printf(" where");
2155             do {
2156                 Type t = name(hd(ms)).type;
2157                 if (isPolyType(t)) {
2158                     t = monotypeOf(t);
2159                 }
2160                 Printf("\n  ");
2161                 printExp(stdout,hd(ms));
2162                 Printf(" :: ");
2163                 if (isNull(tl(fst(snd(t))))) {
2164                     t = snd(snd(t));
2165                 } else {
2166                     t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2167                 }
2168                 printType(stdout,t);
2169                 ms = tl(ms);
2170             } while (nonNull(ms));
2171         }
2172         Putchar('\n');
2173         if (nonNull(ins)) {
2174             Printf("\n-- instances:\n");
2175             do {
2176                 showInst(hd(ins));
2177                 ins = tl(ins);
2178             } while (nonNull(ins));
2179         }
2180         Putchar('\n');
2181     }
2182
2183     if (nonNull(nm)) {                  /* as a function/name              */
2184         printSyntax(nm);
2185         printExp(stdout,nm);
2186         Printf(" :: ");
2187         if (nonNull(name(nm).type)) {
2188             printType(stdout,name(nm).type);
2189         } else {
2190             Printf("<unknown type>");
2191         }
2192         if (isCfun(nm)) {
2193             Printf("  -- data constructor");
2194         } else if (isMfun(nm)) {
2195             Printf("  -- class member");
2196         } else if (isSfun(nm)) {
2197             Printf("  -- selector function");
2198         }
2199         Printf("\n\n");
2200     }
2201
2202
2203     if (isNull(tc) && isNull(cl) && isNull(nm)) {
2204         Printf("Unknown reference `%s'\n",textToStr(t));
2205     }
2206 }
2207
2208 static Void local printSyntax(nm)
2209 Name nm; {
2210     Syntax sy = syntaxOf(nm);
2211     Text   t  = name(nm).text;
2212     String s  = textToStr(t);
2213     if (sy != defaultSyntax(t)) {
2214         Printf("infix");
2215         switch (assocOf(sy)) {
2216             case LEFT_ASS  : Putchar('l'); break;
2217             case RIGHT_ASS : Putchar('r'); break;
2218             case NON_ASS   : break;
2219         }
2220         Printf(" %i ",precOf(sy));
2221         if (isascii((int)(*s)) && isalpha((int)(*s))) {
2222             Printf("`%s`",s);
2223         } else {
2224             Printf("%s",s);
2225         }
2226         Putchar('\n');
2227     }
2228 }
2229
2230 static Void local showInst(in)          /* Display instance decl header    */
2231 Inst in; {
2232     Printf("instance ");
2233     if (nonNull(inst(in).specifics)) {
2234         printContext(stdout,inst(in).specifics);
2235         Printf(" => ");
2236     }
2237     printPred(stdout,inst(in).head);
2238     Putchar('\n');
2239 }
2240
2241 /* --------------------------------------------------------------------------
2242  * List all names currently in scope:
2243  * ------------------------------------------------------------------------*/
2244
2245 static Void local listNames() {         /* list names matching optional pat*/
2246     String pat   = readFilename();
2247     List   names = NIL;
2248     Int    width = getTerminalWidth() - 1;
2249     Int    count = 0;
2250     Int    termPos;
2251     Module mod   = currentModule;
2252
2253     if (pat) {                          /* First gather names to list      */
2254         do {
2255             names = addNamesMatching(pat,names);
2256         } while ((pat=readFilename())!=0);
2257     } else {
2258         names = addNamesMatching((String)0,names);
2259     }
2260     if (isNull(names)) {                /* Then print them out             */
2261         ERRMSG(0) "No names selected"
2262         EEND_NO_LONGJMP;
2263         return;
2264     }
2265     for (termPos=0; nonNull(names); names=tl(names)) {
2266         String s = objToStr(mod,hd(names));
2267         Int    l = strlen(s);
2268         if (termPos+1+l>width) {
2269             Putchar('\n');
2270             termPos = 0;
2271         } else if (termPos>0) {
2272             Putchar(' ');
2273             termPos++;
2274         }
2275         Printf("%s",s);
2276         termPos += l;
2277         count++;
2278     }
2279     Printf("\n(%d names listed)\n", count);
2280 }
2281
2282 /* --------------------------------------------------------------------------
2283  * print a prompt and read a line of input:
2284  * ------------------------------------------------------------------------*/
2285
2286 static Void local promptForInput(moduleName)
2287 String moduleName; {
2288     char promptBuffer[1000];
2289 #if 1
2290     /* This is portable but could overflow buffer */
2291     sprintf(promptBuffer,prompt,moduleName);
2292 #else
2293     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2294      * promptBuffer instead.
2295      */
2296     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2297         /* Reset prompt to a safe default to avoid an infinite loop */
2298         free(prompt);
2299         prompt = strCopy("? ");
2300         internal("Combined prompt and evaluation module name too long");
2301     }
2302 #endif
2303     if (autoMain)
2304        stringInput("main\0"); else
2305        consoleInput(promptBuffer);
2306 }
2307
2308 /* --------------------------------------------------------------------------
2309  * main read-eval-print loop, with error trapping:
2310  * ------------------------------------------------------------------------*/
2311
2312 static Void local interpreter(argc,argv)/* main interpreter loop           */
2313 Int    argc;
2314 String argv[]; {
2315
2316     List   modConIds; /* :: [CONID] */
2317     Bool   prelOK;
2318     String s;
2319
2320     setBreakAction ( HugsIgnoreBreak );
2321     modConIds = initialize(argc,argv);  /* the initial modules to load     */
2322     setBreakAction ( HugsIgnoreBreak );
2323     prelOK    = loadThePrelude();
2324     if (combined) everybody(POSTPREL);
2325
2326     if (!prelOK) {
2327        if (autoMain)
2328           fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2329        else
2330           fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2331        exit(1);
2332     }
2333
2334     loadActions(modConIds);
2335
2336     if (autoMain) {
2337        for (; nonNull(modConIds); modConIds=tl(modConIds))
2338           if (!elemMG(hd(modConIds))) {
2339              fprintf(stderr,
2340                      "hugs +Q: compilation failed -- can't run `main'\n" );
2341              exit(1);
2342           }
2343     }
2344
2345     modConIds = NIL;
2346
2347     /* initialize calls startupHaskell, which trashes our signal handlers */
2348     setBreakAction ( HugsIgnoreBreak );
2349     forHelp();
2350
2351     for (;;) {
2352         Command cmd;
2353         everybody(RESET);               /* reset to sensible initial state */
2354
2355         promptForInput(textToStr(module(currentModule).text));
2356
2357         cmd = readCommand(cmds, (Char)':', (Char)'!');
2358         switch (cmd) {
2359             case EDIT   : editor();
2360                           break;
2361             case FIND   : find();
2362                           break;
2363             case LOAD   : modConIds = NIL;
2364                           while ((s=readFilename())!=0)
2365                              modConIds = cons(mkCon(findText(s)),modConIds);
2366                           loadActions(modConIds);
2367                           modConIds = NIL;
2368                           break;
2369             case ALSO   : modConIds = NIL;
2370                           while ((s=readFilename())!=0)
2371                              modConIds = cons(mkCon(findText(s)),modConIds);
2372                           addActions(modConIds);
2373                           modConIds = NIL;
2374                           break;
2375             case RELOAD : refreshActions(NIL);
2376                           break;
2377             case SETMODULE :
2378                           setModule();
2379                           break;
2380             case EVAL   : evaluator();
2381                           break;
2382             case TYPEOF : showtype();
2383                           break;
2384             case BROWSE : browse();
2385                           break;
2386 #if EXPLAIN_INSTANCE_RESOLUTION
2387             case XPLAIN : xplain();
2388                           break;
2389 #endif
2390             case NAMES  : listNames();
2391                           break;
2392             case HELP   : menu();
2393                           break;
2394             case BADCMD : guidance();
2395                           break;
2396             case SET    : set();
2397                           break;
2398             case STATS:
2399 #ifdef CRUDE_PROFILING
2400                           cp_show();
2401 #endif
2402                           break;
2403             case SYSTEM : if (shellEsc(readLine()))
2404                               Printf("Warning: Shell escape terminated abnormally\n");
2405                           break;
2406             case CHGDIR : changeDir();
2407                           break;
2408             case INFO   : info();
2409                           break;
2410             case PNTVER: Printf("-- Hugs Version %s\n",
2411                                  HUGS_VERSION);
2412                           break;
2413             case DUMP   : dumpStg();
2414                           break;
2415             case QUIT   : return;
2416             case COLLECT: consGC = FALSE;
2417                           garbageCollect();
2418                           consGC = TRUE;
2419                           Printf("Garbage collection recovered %d cells\n",
2420                                  cellsRecovered);
2421                           break;
2422             case NOCMD  : break;
2423         }
2424
2425         if (autoMain) break;
2426     }
2427 }
2428
2429 /* --------------------------------------------------------------------------
2430  * Display progress towards goal:
2431  * ------------------------------------------------------------------------*/
2432
2433 static Target currTarget;
2434 static Bool   aiming = FALSE;
2435 static Int    currPos;
2436 static Int    maxPos;
2437 static Int    charCount;
2438
2439 Void setGoal(what, t)                  /* Set goal for what to be t        */
2440 String what;
2441 Target t; {
2442     if (quiet)
2443       return;
2444 #if EXPLAIN_INSTANCE_RESOLUTION
2445     if (showInstRes)
2446       return;
2447 #endif
2448     currTarget = (t?t:1);
2449     aiming     = TRUE;
2450     if (useDots) {
2451         currPos = strlen(what);
2452         maxPos  = getTerminalWidth() - 1;
2453         Printf("%s",what);
2454     }
2455     else
2456         for (charCount=0; *what; charCount++)
2457             Putchar(*what++);
2458     FlushStdout();
2459 }
2460
2461 Void soFar(t)                          /* Indicate progress towards goal   */
2462 Target t; {                            /* has now reached t                */
2463     if (quiet)
2464       return;
2465 #if EXPLAIN_INSTANCE_RESOLUTION
2466     if (showInstRes)
2467       return;
2468 #endif
2469     if (useDots) {
2470         Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2471
2472         if (newPos>maxPos)
2473             newPos = maxPos;
2474
2475         if (newPos>currPos) {
2476             do
2477                 Putchar('.');
2478             while (newPos>++currPos);
2479             FlushStdout();
2480         }
2481         FlushStdout();
2482     }
2483 }
2484
2485 Void done() {                          /* Goal has now been achieved       */
2486     if (quiet)
2487       return;
2488 #if EXPLAIN_INSTANCE_RESOLUTION
2489     if (showInstRes)
2490       return;
2491 #endif
2492     if (useDots) {
2493         while (maxPos>currPos++)
2494             Putchar('.');
2495         Putchar('\n');
2496     }
2497     else
2498         for (; charCount>0; charCount--) {
2499             Putchar('\b');
2500             Putchar(' ');
2501             Putchar('\b');
2502         }
2503     aiming = FALSE;
2504     FlushStdout();
2505 }
2506
2507 static Void local failed() {           /* Goal cannot be reached due to    */
2508     if (aiming) {                      /* errors                           */
2509         aiming = FALSE;
2510         Putchar('\n');
2511         FlushStdout();
2512     }
2513 }
2514
2515 /* --------------------------------------------------------------------------
2516  * Error handling:
2517  * ------------------------------------------------------------------------*/
2518
2519 static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
2520     if (printing) {                    /* after successful termination or  */
2521         printing = FALSE;              /* runtime error (e.g. interrupt)   */
2522         Putchar('\n');
2523         if (showStats) {
2524 #define plural(v)   v, (v==1?"":"s")
2525             Printf("%lu cell%s",plural(numCells));
2526             if (numGcs>0)
2527                 Printf(", %u garbage collection%s",plural(numGcs));
2528             Printf(")\n");
2529 #undef plural
2530         }
2531         FlushStdout();
2532         garbageCollect();
2533     }
2534 }
2535
2536 Cell errAssert(l)   /* message to use when raising asserts, etc */
2537 Int l; {
2538   char tmp[100];
2539   Cell str;
2540   if (currentFile) {
2541     str = mkStr(findText(currentFile));
2542   } else {
2543     str = mkStr(findText(""));
2544   }
2545   return (ap2(nameTangleMessage,str,mkInt(l)));
2546 }
2547
2548 Void errHead(l)                        /* print start of error message     */
2549 Int l; {
2550     failed();                          /* failed to reach target ...       */
2551     stopAnyPrinting();
2552     FPrintf(errorStream,"ERROR");
2553
2554     if (currentFile) {
2555         FPrintf(errorStream," \"%s\"", currentFile);
2556         setLastEdit(currentFile,l);
2557         if (l) FPrintf(errorStream," (line %d)",l);
2558         currentFile = NULL;
2559     }
2560     FPrintf(errorStream,": ");
2561     FFlush(errorStream);
2562 }
2563
2564 Void errFail() {                        /* terminate error message and     */
2565     Putc('\n',errorStream);             /* produce exception to return to  */
2566     FFlush(errorStream);                /* main command loop               */
2567     longjmp(catch_error,1);
2568 }
2569
2570 Void errFail_no_longjmp() {             /* terminate error message but     */
2571     Putc('\n',errorStream);             /* don't produce an exception      */
2572     FFlush(errorStream);
2573 }
2574
2575 Void errAbort() {                       /* altern. form of error handling  */
2576     failed();                           /* used when suitable error message*/
2577     stopAnyPrinting();                  /* has already been printed        */
2578     errFail();
2579 }
2580
2581 Void internal(msg)                      /* handle internal error           */
2582 String msg; {
2583     failed();
2584     stopAnyPrinting();
2585     Printf("INTERNAL ERROR: %s\n",msg);
2586     FlushStdout();
2587 exit(9);
2588     longjmp(catch_error,1);
2589 }
2590
2591 Void fatal(msg)                         /* handle fatal error              */
2592 String msg; {
2593     FlushStdout();
2594     Printf("\nFATAL ERROR: %s\n",msg);
2595     everybody(EXIT);
2596     exit(1);
2597 }
2598
2599
2600 /* --------------------------------------------------------------------------
2601  * Read value from environment variable or registry:
2602  * ------------------------------------------------------------------------*/
2603
2604 String fromEnv(var,def)         /* return value of:                        */
2605 String var;                     /*     environment variable named by var   */
2606 String def; {                   /* or: default value given by def          */
2607     String s = getenv(var);
2608     return (s ? s : def);
2609 }
2610
2611 /* --------------------------------------------------------------------------
2612  * String manipulation routines:
2613  * ------------------------------------------------------------------------*/
2614
2615 static String local strCopy(s)         /* make malloced copy of a string   */
2616 String s; {
2617     if (s && *s) {
2618         char *t, *r;
2619         if ((t=(char *)malloc(strlen(s)+1))==0) {
2620             ERRMSG(0) "String storage space exhausted"
2621             EEND;
2622         }
2623         for (r=t; (*r++ = *s++)!=0; ) {
2624         }
2625         return t;
2626     }
2627     return NULL;
2628 }
2629
2630 /* --------------------------------------------------------------------------
2631  * Compiler output
2632  * We can redirect compiler output (prompts, error messages, etc) by
2633  * tweaking these functions.
2634  * ------------------------------------------------------------------------*/
2635
2636 /* --------------------------------------------------------------------------
2637  * Send message to each component of system:
2638  * ------------------------------------------------------------------------*/
2639
2640 Void everybody(what)            /* send command `what' to each component of*/
2641 Int what; {                     /* system to respond as appropriate ...    */
2642 #if 0
2643   fprintf ( stderr, "EVERYBODY %d\n", what );
2644 #endif
2645     machdep(what);              /* The order of calling each component is  */
2646     storage(what);              /* important for the PREPREL command       */
2647     substitution(what);
2648     input(what);
2649     translateControl(what);
2650     linkControl(what);
2651     staticAnalysis(what);
2652     deriveControl(what);
2653     typeChecker(what);
2654     compiler(what);
2655     codegen(what);
2656 }
2657
2658 /*-------------------------------------------------------------------------*/