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