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