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.70 $
  13  * $Date: 2000/05/10 09:00:20 $
  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 static ConId currentModule_failed = NIL; /* Remember failed module from :r */
 126
 127
 128
 129 /* --------------------------------------------------------------------------
 130  * Hugs entry point:
 131  * ------------------------------------------------------------------------*/
 132
 133 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
 134
 135 Main main ( Int, String [] );       /* now every func has a prototype  */
 136
 137 Main main(argc,argv)
 138 int  argc;
 139 char *argv[]; {
 140 #ifdef HAVE_CONSOLE_H /* Macintosh port */
 141     _ftype = 'TEXT';
 142     _fcreator = 'R*ch';       /*  // 'KAHL';      //'*TEX';       //'ttxt'; */
 143
 144     console_options.top = 50;
 145     console_options.left = 20;
 146
 147     console_options.nrows = 32;
 148     console_options.ncols = 80;
 149
 150     console_options.pause_atexit = 1;
 151     console_options.title = "\pHugs";
 152
 153     console_options.procID = 5;
 154     argc = ccommand(&argv);
 155 #endif
 156
 157     CStackBase = &argc;                 /* Save stack base for use in gc   */
 158
 159 #ifdef DEBUG
 160 #if 0
 161     checkBytecodeCount();               /* check for too many bytecodes    */
 162 #endif
 163 #endif
 164
 165     /* If first arg is +Q or -Q, be entirely silent, and automatically run
 166        main after loading scripts.  Useful for running the nofib suite.    */
 167     if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
 168        autoMain = TRUE;
 169        if (strcmp(argv[1],"-Q") == 0) {
 170          EnableOutput(0);
 171        }
 172     }
 173
 174     Printf("__   __ __  __  ____   ___      _________________________________________\n");
 175     Printf("||   || ||  || ||  || ||__      STGHugs: Based on the Haskell 98 standard\n");
 176     Printf("||___|| ||__|| ||__||  __||     Copyright (c) 1994-2000\n");
 177     Printf("||---||         ___||           World Wide Web: http://haskell.org/hugs\n");
 178     Printf("||   ||                         Report bugs to: hugs-bugs@haskell.org\n");
 179     Printf("||   || Version: %s _________________________________________\n\n",HUGS_VERSION);
 180
 181     /* Get the absolute path to the directory containing the hugs
 182        executable, so that we know where the Prelude and nHandle.so/.dll are.
 183        We do this by reading env var STGHUGSDIR.  This needs to succeed, so
 184        setInstallDir won't return unless it succeeds.
 185     */
 186     setInstallDir ( argv[0] );
 187
 188 #if SYMANTEC_C
 189     Printf("   Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
 190 #endif
 191     FlushStdout();
 192     interpreter(argc,argv);
 193     Printf("[Leaving Hugs]\n");
 194     everybody(EXIT);
 195     shutdownHaskell();
 196     FlushStdout();
 197     fflush(stderr);
 198     exit(0);
 199     MainDone();
 200 }
 201
 202 #endif
 203
 204 /* --------------------------------------------------------------------------
 205  * Initialization, interpret command line args and read prelude:
 206  * ------------------------------------------------------------------------*/
 207
 208 static List /*CONID*/ initialize ( Int argc, String argv[] )
 209 {
 210    Int    i, j;
 211    List   initialModules;
 212
 213    setLastEdit((String)0,0);
 214    lastEdit      = 0;
 215    currentFile   = NULL;
 216
 217 #if SYMANTEC_C
 218    hugsEdit      = "";
 219 #else
 220    hugsEdit      = strCopy(fromEnv("EDITOR",NULL));
 221 #endif
 222    hugsPath      = strCopy(HUGSPATH);
 223    readOptions("-p\"%s> \" -r$$");
 224    readOptions(fromEnv("STGHUGSFLAGS",""));
 225
 226 #  if DEBUG
 227    {
 228       char exe_name[N_INSTALLDIR + 6];
 229       strcpy(exe_name, installDir);
 230       strcat(exe_name, "hugs");
 231       DEBUG_LoadSymbols(exe_name);
 232    }
 233 #  endif
 234
 235    /* startupHaskell extracts args between +RTS ... -RTS, and sets
 236       prog_argc/prog_argv to the rest.  We want to further process
 237       the rest, so we then get hold of them again.
 238    */
 239    startupHaskell ( argc, argv, NULL );
 240    getProgArgv ( &argc, &argv );
 241
 242    /* Find out early on if we're in combined mode or not.
 243       everybody(PREPREL) needs to know this.  Also, establish the
 244       heap size;
 245    */
 246    for (i = 1; i < argc; ++i) {
 247       if (strcmp(argv[i], "--")==0) break;
 248       if (strcmp(argv[i], "-c")==0) combined = FALSE;
 249       if (strcmp(argv[i], "+c")==0) combined = TRUE;
 250
 251       if (strncmp(argv[i],"+h",2)==0 || strncmp(argv[i],"-h",2)==0)
 252          setHeapSize(&(argv[i][2]));
 253    }
 254
 255    everybody(PREPREL);
 256    initialModules = NIL;
 257
 258    for (i = 1; i < argc; ++i) {          /* process command line arguments  */
 259       if (strcmp(argv[i], "--")==0)
 260          { argv[i] = NULL; break; }
 261       if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/) {
 262          if (!processOption(argv[i]))
 263             initialModules
 264                = cons ( mkCon(findText(argv[i])), initialModules );
 265          argv[i] = NULL;
 266       }
 267    }
 268
 269    if (haskell98) {
 270        Printf("Haskell 98 mode: Restart with command line option -98"
 271               " to enable extensions\n");
 272    } else {
 273        Printf("Hugs mode: Restart with command line option +98 for"
 274               " Haskell 98 mode\n");
 275    }
 276
 277    if (combined) {
 278        Printf("Combined mode: Restart with command line -c for"
 279               " standalone mode\n\n" );
 280    } else {
 281        Printf("Standalone mode: Restart with command line +c for"
 282               " combined mode\n\n" );
 283    }
 284
 285    /* slide args back over the deleted ones. */
 286    j = 1;
 287    for (i = 1; i < argc; i++)
 288       if (argv[i])
 289          argv[j++] = argv[i];
 290
 291    argc = j;
 292
 293    setProgArgv ( argc, argv );
 294
 295    initDone = TRUE;
 296    return initialModules;
 297 }
 298
 299 /* --------------------------------------------------------------------------
 300  * Command line options:
 301  * ------------------------------------------------------------------------*/
 302
 303 struct options {                        /* command line option toggles     */
 304     char   c;                           /* table defined in main app.      */
 305     int    h98;
 306     String description;
 307     Bool   *flag;
 308 };
 309 extern struct options toggle[];
 310
 311 static Void local toggleSet(c,state)    /* Set command line toggle         */
 312 Char c;
 313 Bool state; {
 314     Int i;
 315     for (i=0; toggle[i].c; ++i)
 316         if (toggle[i].c == c) {
 317             *toggle[i].flag = state;
 318             return;
 319         }
 320     clearCurrentFile();
 321     ERRMSG(0) "Unknown toggle `%c'", c
 322     EEND_NO_LONGJMP;
 323 }
 324
 325 static Void local togglesIn(state)      /* Print current list of toggles in*/
 326 Bool state; {                           /* given state                     */
 327     Int count = 0;
 328     Int i;
 329     for (i=0; toggle[i].c; ++i)
 330         if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
 331             if (count==0)
 332                 Putchar((char)(state ? '+' : '-'));
 333             Putchar(toggle[i].c);
 334             count++;
 335         }
 336     if (count>0)
 337         Putchar(' ');
 338 }
 339
 340 static Void local optionInfo() {        /* Print information about command */
 341     static String fmts = "%-5s%s\n";    /* line settings                   */
 342     static String fmtc = "%-5c%s\n";
 343     Int    i;
 344
 345     Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
 346     for (i=0; toggle[i].c; ++i) {
 347         if (!haskell98 || toggle[i].h98) {
 348             Printf(fmtc,toggle[i].c,toggle[i].description);
 349         }
 350     }
 351
 352     Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
 353     Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
 354     Printf(fmts,"pstr","Set prompt string to str");
 355     Printf(fmts,"rstr","Set repeat last expression string to str");
 356     Printf(fmts,"Pstr","Set search path for modules to str");
 357     Printf(fmts,"Estr","Use editor setting given by str");
 358     Printf(fmts,"cnum","Set constraint cutoff limit");
 359 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 360     Printf(fmts,"Fstr","Set preprocessor filter to str");
 361 #endif
 362
 363     Printf("\nCurrent settings: ");
 364     togglesIn(TRUE);
 365     togglesIn(FALSE);
 366     Printf("-h%d",heapSize);
 367     Printf(" -p");
 368     printString(prompt);
 369     Printf(" -r");
 370     printString(repeatStr);
 371     Printf(" -c%d",cutoff);
 372     Printf("\nSearch path     : -P");
 373     printString(hugsPath);
 374 #if 0
 375 ToDo
 376     if (projectPath!=NULL) {
 377         Printf("\nProject Path    : %s",projectPath);
 378     }
 379 #endif
 380     Printf("\nEditor setting  : -E");
 381     printString(hugsEdit);
 382 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 383     Printf("\nPreprocessor    : -F");
 384     printString(preprocessor);
 385 #endif
 386     Printf("\nCompatibility   : %s", haskell98 ? "Haskell 98 (+98)"
 387                                                : "Hugs Extensions (-98)");
 388     Putchar('\n');
 389 }
 390
 391 #undef PUTC
 392 #undef PUTS
 393 #undef PUTInt
 394 #undef PUTStr
 395
 396 static Void local readOptions(options)         /* read options from string */
 397 String options; {
 398     String s;
 399     if (options) {
 400         stringInput(options);
 401         while ((s=readFilename())!=0) {
 402             if (*s && !processOption(s)) {
 403                 ERRMSG(0) "Option string must begin with `+' or `-'"
 404                 EEND;
 405             }
 406         }
 407     }
 408 }
 409
 410 static Bool local processOption(s)      /* process string s for options,   */
 411 String s; {                             /* return FALSE if none found.     */
 412     Bool state;
 413
 414     if (s[0]=='-')
 415         state = FALSE;
 416     else if (s[0]=='+')
 417         state = TRUE;
 418     else
 419         return FALSE;
 420
 421     while (*++s)
 422         switch (*s) {
 423             case 'Q' : break;                           /* already handled */
 424
 425             case 'p' : if (s[1]) {
 426                            if (prompt) free(prompt);
 427                            prompt = strCopy(s+1);
 428                        }
 429                        return TRUE;
 430
 431             case 'r' : if (s[1]) {
 432                            if (repeatStr) free(repeatStr);
 433                            repeatStr = strCopy(s+1);
 434                        }
 435                        return TRUE;
 436
 437             case 'P' : {
 438                            String p = substPath(s+1,hugsPath ? hugsPath : "");
 439                            if (hugsPath) free(hugsPath);
 440                            hugsPath = p;
 441                            return TRUE;
 442                        }
 443
 444             case 'E' : if (hugsEdit) free(hugsEdit);
 445                        hugsEdit = strCopy(s+1);
 446                        return TRUE;
 447
 448 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 449             case 'F' : if (preprocessor) free(preprocessor);
 450                        preprocessor = strCopy(s+1);
 451                        return TRUE;
 452 #endif
 453
 454             case 'h' : /* don't do anything, since pre-scan of args
 455                        will have got it already */
 456                        return TRUE;
 457
 458             case 'c' :  /* don't do anything, since pre-scan of args
 459                            will have got it already */
 460                        return TRUE;
 461
 462             case 'D' : /* hack */
 463                 {
 464                     extern void setRtsFlags( int x );
 465                     setRtsFlags(argToInt(s+1));
 466                     return TRUE;
 467                 }
 468
 469             default  : if (strcmp("98",s)==0) {
 470                            if (initDone && ((state && !haskell98) ||
 471                                                (!state && haskell98))) {
 472                                FPrintf(stderr,
 473                                        "Haskell 98 compatibility cannot be changed"
 474                                        " while the interpreter is running\n");
 475                            } else {
 476                                haskell98 = state;
 477                            }
 478                            return TRUE;
 479                        } else {
 480                            toggleSet(*s,state);
 481                        }
 482                        break;
 483         }
 484     return TRUE;
 485 }
 486
 487 static Void local setHeapSize(s)
 488 String s; {
 489     if (s) {
 490         hpSize = argToInt(s);
 491         if (hpSize < MINIMUMHEAP)
 492             hpSize = MINIMUMHEAP;
 493         else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
 494             hpSize = MAXIMUMHEAP;
 495         if (initDone && hpSize != heapSize) {
 496             /* ToDo: should this use a message box in winhugs? */
 497             FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
 498         } else {
 499             heapSize = hpSize;
 500         }
 501     }
 502 }
 503
 504 static Int local argToInt(s)            /* read integer from argument str  */
 505 String s; {
 506     Int    n = 0;
 507     String t = s;
 508
 509     if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
 510         ERRMSG(0) "Missing integer in option setting \"%s\"", t
 511         EEND;
 512     }
 513
 514     do {
 515         Int d = (*s++) - '0';
 516         if (n > ((MAXPOSINT - d)/10)) {
 517             ERRMSG(0) "Option setting \"%s\" is too large", t
 518             EEND;
 519         }
 520         n     = 10*n + d;
 521     } while (isascii((int)(*s)) && isdigit((int)(*s)));
 522
 523     if (*s=='K' || *s=='k') {
 524         if (n > (MAXPOSINT/1000)) {
 525             ERRMSG(0) "Option setting \"%s\" is too large", t
 526             EEND;
 527         }
 528         n *= 1000;
 529         s++;
 530     }
 531
 532 #if MAXPOSINT > 1000000                 /* waste of time on 16 bit systems */
 533     if (*s=='M' || *s=='m') {
 534         if (n > (MAXPOSINT/1000000)) {
 535             ERRMSG(0) "Option setting \"%s\" is too large", t
 536             EEND;
 537         }
 538         n *= 1000000;
 539         s++;
 540     }
 541 #endif
 542
 543 #if MAXPOSINT > 1000000000
 544     if (*s=='G' || *s=='g') {
 545         if (n > (MAXPOSINT/1000000000)) {
 546             ERRMSG(0) "Option setting \"%s\" is too large", t
 547             EEND;
 548         }
 549         n *= 1000000000;
 550         s++;
 551     }
 552 #endif
 553
 554     if (*s!='\0') {
 555         ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
 556         EEND;
 557     }
 558
 559     return n;
 560 }
 561
 562 /* --------------------------------------------------------------------------
 563  * Print Menu of list of commands:
 564  * ------------------------------------------------------------------------*/
 565
 566 static struct cmd cmds[] = {
 567  {":?",      HELP},   {":cd",   CHGDIR},  {":also",    ALSO},
 568  {":type",   TYPEOF}, {":!",    SYSTEM},  {":load",    LOAD},
 569  {":reload", RELOAD}, {":gc",   COLLECT}, {":edit",    EDIT},
 570  {":quit",   QUIT},   {":set",  SET},     {":find",    FIND},
 571  {":names",  NAMES},  {":info", INFO},    {":project", PROJECT},
 572  {":dump",   DUMP},
 573  {":module", SETMODULE},
 574  {":browse", BROWSE},
 575 #if EXPLAIN_INSTANCE_RESOLUTION
 576  {":xplain", XPLAIN},
 577 #endif
 578  {":version", PNTVER},
 579  {"",      EVAL},
 580  {0,0}
 581 };
 582
 583 static Void local menu() {
 584     Printf("LIST OF COMMANDS:  Any command may be abbreviated to :c where\n");
 585     Printf("c is the first character in the full name.\n\n");
 586     Printf(":load <filenames>   load modules from specified files\n");
 587     Printf(":load               clear all files except prelude\n");
 588     Printf(":also <filenames>   read additional modules\n");
 589     Printf(":reload             repeat last load command\n");
 590     Printf(":project <filename> use project file\n");
 591     Printf(":edit <filename>    edit file\n");
 592     Printf(":edit               edit last module\n");
 593     Printf(":module <module>    set module for evaluating expressions\n");
 594     Printf("<expr>              evaluate expression\n");
 595     Printf(":type <expr>        print type of expression\n");
 596     Printf(":?                  display this list of commands\n");
 597     Printf(":set <options>      set command line options\n");
 598     Printf(":set                help on command line options\n");
 599     Printf(":names [pat]        list names currently in scope\n");
 600     Printf(":info <names>       describe named objects\n");
 601     Printf(":browse <modules>   browse names defined in <modules>\n");
 602 #if EXPLAIN_INSTANCE_RESOLUTION
 603     Printf(":xplain <context>   explain instance resolution for <context>\n");
 604 #endif
 605     Printf(":find <name>        edit module containing definition of name\n");
 606     Printf(":!command           shell escape\n");
 607     Printf(":cd dir             change directory\n");
 608     Printf(":gc                 force garbage collection\n");
 609     Printf(":version            print Hugs version\n");
 610     Printf(":dump <name>        print STG code for named fn\n");
 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 /* Refresh the current target modules, and attempt to set the
1532    current module to what it was before (ie currentModule):
1533      if currentModule_failed is different from currentModule,
1534         use that instead
1535      if nextCurrMod is non null, try to set it to that instead
1536      if the one we're after insn't available, select a target
1537        from the end of the module group list.
1538 */
1539 static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
1540 {
1541    List t;
1542    ConId tryFor;
1543
1544    /* Remember what the old current module was. */
1545    tryFor = mkCon(module(currentModule).text);
1546
1547    /* Do the Real Work. */
1548    achieveTargetModules(FALSE);
1549
1550    /* Remember if the current module was invalidated by this
1551       refresh, so later refreshes can attempt to reload it. */
1552    if (!elemMG(tryFor))
1553       currentModule_failed = tryFor;
1554
1555    /* If a previous refresh failed to get an old current module,
1556       try for that instead. */
1557    if (nonNull(currentModule_failed)
1558        && textOf(currentModule_failed) != textOf(tryFor)
1559        && elemMG(currentModule_failed))
1560       tryFor = currentModule_failed;
1561    /* If our caller specified a new current module, that overrides
1562       all historical settings. */
1563    if (nonNull(nextCurrMod))
1564       tryFor = nextCurrMod;
1565    /* Finally, if we can't actually get hold of whatever it was we
1566       were after, select something which is possible. */
1567    if (!elemMG(tryFor))
1568       tryFor = selectLatestMG();
1569
1570    /* combined mode kludge, to get Prelude rather than PrelHugs */
1571    if (combined && textOf(tryFor)==findText("PrelHugs"))
1572       tryFor = mkCon(findText("Prelude"));
1573
1574    if (cleanAfter) {
1575       /* delete any targetModules which didn't actually get loaded  */
1576       t = targetModules;
1577       targetModules = NIL;
1578       for (; nonNull(t); t=tl(t))
1579          if (elemMG(hd(t)))
1580             targetModules = cons(hd(t),targetModules);
1581    }
1582
1583    setCurrModule ( findModule(textOf(tryFor)) );
1584    Printf("Hugs session for:\n");
1585    ppMG();
1586 }
1587
1588
1589 static void addActions ( List extraModules /* :: [CONID] */ )
1590 {
1591    List t;
1592    for (t = extraModules; nonNull(t); t=tl(t)) {
1593       ConId extra = hd(t);
1594       if (!varIsMember(textOf(extra),targetModules))
1595          targetModules = cons(extra,targetModules);
1596    }
1597    refreshActions ( isNull(extraModules)
1598                        ? NIL
1599                        : hd(reverse(extraModules)),
1600                     TRUE
1601                   );
1602 }
1603
1604
1605 static void loadActions ( List loadModules /* :: [CONID] */ )
1606 {
1607    List t;
1608    targetModules = dupList ( prelModules );
1609
1610    for (t = loadModules; nonNull(t); t=tl(t)) {
1611       ConId load = hd(t);
1612       if (!varIsMember(textOf(load),targetModules))
1613          targetModules = cons(load,targetModules);
1614    }
1615    refreshActions ( isNull(loadModules)
1616                        ? NIL
1617                        : hd(reverse(loadModules)),
1618                     TRUE
1619                   );
1620 }
1621
1622
1623 /* --------------------------------------------------------------------------
1624  * Access to external editor:
1625  * ------------------------------------------------------------------------*/
1626
1627 /* ToDo: All this editor stuff needs fixing. */
1628
1629 static Void local editor() {            /* interpreter-editor interface    */
1630 #if 0
1631     String newFile  = readFilename();
1632     if (newFile) {
1633         setLastEdit(newFile,0);
1634         if (readFilename()) {
1635             ERRMSG(0) "Multiple filenames not permitted"
1636             EEND;
1637         }
1638     }
1639     runEditor();
1640 #endif
1641 }
1642
1643 static Void local find() {              /* edit file containing definition */
1644 #if 0
1645 ToDo: Fix!
1646     String nm = readFilename();         /* of specified name               */
1647     if (!nm) {
1648         ERRMSG(0) "No name specified"
1649         EEND;
1650     }
1651     else if (readFilename()) {
1652         ERRMSG(0) "Multiple names not permitted"
1653         EEND;
1654     }
1655     else {
1656         Text t;
1657         Cell c;
1658         setCurrModule(findEvalModule());
1659         startNewScript(0);
1660         if (nonNull(c=findTycon(t=findText(nm)))) {
1661             if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1662                 readScripts(N_PRELUDE_SCRIPTS);
1663             }
1664         } else if (nonNull(c=findName(t))) {
1665             if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1666                 readScripts(N_PRELUDE_SCRIPTS);
1667             }
1668         } else {
1669             ERRMSG(0) "No current definition for name \"%s\"", nm
1670             EEND;
1671         }
1672     }
1673 #endif
1674 }
1675
1676 static Void local runEditor() {         /* run editor on script lastEdit   */
1677 #if 0
1678     if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine              */
1679         readScripts(N_PRELUDE_SCRIPTS);
1680 #endif
1681 }
1682
1683 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1684 String fname;
1685 Int    line; {
1686 #if 0
1687     if (lastEdit)
1688         free(lastEdit);
1689     lastEdit = strCopy(fname);
1690     lastEdLine = line;
1691 #endif
1692 }
1693
1694 /* --------------------------------------------------------------------------
1695  * Read and evaluate an expression:
1696  * ------------------------------------------------------------------------*/
1697
1698 static Void setModule ( void ) {
1699                               /*set module in which to evaluate expressions*/
1700    Module m;
1701    ConId  mc = NIL;
1702    String s  = readFilename();
1703    if (!s) {
1704       mc = selectLatestMG();
1705       if (combined && textOf(mc)==findText("PrelHugs"))
1706          mc = mkCon(findText("Prelude"));
1707       m = findModule(textOf(mc));
1708       assert(nonNull(m));
1709    } else {
1710       m = findModule(findText(s));
1711       if (isNull(m)) {
1712          ERRMSG(0) "Cannot find module \"%s\"", s
1713          EEND_NO_LONGJMP;
1714          return;
1715       }
1716    }
1717    setCurrModule(m);
1718 }
1719
1720 static Module allocEvalModule ( void )
1721 {
1722    Module evalMod = newModule( findText("_Eval_Module_") );
1723    module(evalMod).names   = module(currentModule).names;
1724    module(evalMod).tycons  = module(currentModule).tycons;
1725    module(evalMod).classes = module(currentModule).classes;
1726    module(evalMod).qualImports
1727      = singleton(pair(mkCon(textPrelude),modulePrelude));
1728    return evalMod;
1729 }
1730
1731 static Void local evaluator() {        /* evaluate expr and print value    */
1732     volatile Type   type;
1733     volatile Type   bd;
1734     volatile Kinds  ks      = NIL;
1735     volatile Module evalMod = allocEvalModule();
1736     volatile Module currMod = currentModule;
1737     setCurrModule(evalMod);
1738     currentFile = NULL;
1739
1740     defaultDefns = combined ? stdDefaults : evalDefaults;
1741
1742     setBreakAction ( HugsLongjmpOnBreak );
1743     if (setjmp(catch_error)==0) {
1744        /* try this */
1745        parseExp();
1746        checkExp();
1747        type = typeCheckExp(TRUE);
1748     } else {
1749        /* if an exception happens, we arrive here */
1750        setBreakAction ( HugsIgnoreBreak );
1751        goto cleanup_and_return;
1752     }
1753
1754     setBreakAction ( HugsIgnoreBreak );
1755     if (isPolyType(type)) {
1756         ks = polySigOf(type);
1757         bd = monotypeOf(type);
1758     }
1759     else
1760         bd = type;
1761
1762     if (whatIs(bd)==QUAL) {
1763         printing = FALSE;
1764        clearCurrentFile();
1765        ERRMSG(0) "Unresolved overloading" ETHEN
1766        ERRTEXT   "\n*** Type       : "    ETHEN ERRTYPE(type);
1767        ERRTEXT   "\n*** Expression : "    ETHEN ERREXPR(inputExpr);
1768        ERRTEXT   "\n"
1769        EEND_NO_LONGJMP;
1770        goto cleanup_and_return;
1771     }
1772
1773 #if 1
1774     printing      = TRUE;
1775     numEnters     = 0;
1776     if (isProgType(ks,bd)) {
1777         inputExpr = ap(nameRunIO_toplevel,inputExpr);
1778         evalExp();
1779         Putchar('\n');
1780     } else {
1781         Cell d = provePred(ks,NIL,ap(classShow,bd));
1782         if (isNull(d)) {
1783            clearCurrentFile();
1784            printing = FALSE;
1785            ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1786            ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
1787            ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
1788            ERRTEXT   "\n"
1789            EEND_NO_LONGJMP;
1790            goto cleanup_and_return;
1791         }
1792         inputExpr = ap2(nameShow,           d,inputExpr);
1793         inputExpr = ap (namePutStr,         inputExpr);
1794         inputExpr = ap (nameRunIO_toplevel, inputExpr);
1795
1796         evalExp(); printf("\n");
1797         if (addType) {
1798             printf(" :: ");
1799             printType(stdout,type);
1800             Putchar('\n');
1801         }
1802     }
1803
1804 #else
1805
1806    printf ( "result type is " );
1807    printType ( stdout, type );
1808    printf ( "\n" );
1809    evalExp();
1810    printf ( "\n" );
1811
1812 #endif
1813
1814   cleanup_and_return:
1815    setBreakAction ( HugsIgnoreBreak );
1816    nukeModule(evalMod);
1817    setCurrModule(currMod);
1818    setCurrentFile(currMod);
1819    stopAnyPrinting();
1820 }
1821
1822
1823
1824 /* --------------------------------------------------------------------------
1825  * Print type of input expression:
1826  * ------------------------------------------------------------------------*/
1827
1828 static Void showtype ( void ) {        /* print type of expression (if any)*/
1829
1830     volatile Cell   type;
1831     volatile Module evalMod = allocEvalModule();
1832     volatile Module currMod = currentModule;
1833     setCurrModule(evalMod);
1834
1835     if (setjmp(catch_error)==0) {
1836        /* try this */
1837        parseExp();
1838        checkExp();
1839        defaultDefns = evalDefaults;
1840        type = typeCheckExp(FALSE);
1841        printExp(stdout,inputExpr);
1842        Printf(" :: ");
1843        printType(stdout,type);
1844        Putchar('\n');
1845     } else {
1846        /* if an exception happens, we arrive here */
1847     }
1848
1849     nukeModule(evalMod);
1850     setCurrModule(currMod);
1851 }
1852
1853
1854 static Void local browseit(mod,t,all)
1855 Module mod;
1856 String t;
1857 Bool all; {
1858     if (nonNull(mod)) {
1859         Cell cs;
1860         if (nonNull(t))
1861             Printf("module %s where\n",textToStr(module(mod).text));
1862         for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1863             Name nm = hd(cs);
1864             /* only look at things defined in this module,
1865                unless `all' flag is set */
1866             if (all || name(nm).mod == mod) {
1867                 /* unwanted artifacts, like lambda lifted values,
1868                    are in the list of names, but have no types */
1869                 if (nonNull(name(nm).type)) {
1870                     printExp(stdout,nm);
1871                     Printf(" :: ");
1872                     printType(stdout,name(nm).type);
1873                     if (isCfun(nm)) {
1874                         Printf("  -- data constructor");
1875                     } else if (isMfun(nm)) {
1876                         Printf("  -- class member");
1877                     } else if (isSfun(nm)) {
1878                         Printf("  -- selector function");
1879                     }
1880                     Printf("\n");
1881                 }
1882             }
1883         }
1884     } else {
1885       if (isNull(mod)) {
1886         Printf("Unknown module %s\n",t);
1887       }
1888     }
1889 }
1890
1891 static Void local browse() {            /* browse modules                  */
1892     Int    count = 0;                   /* or give menu of commands        */
1893     String s;
1894     Bool all = FALSE;
1895
1896     for (; (s=readFilename())!=0; count++)
1897         if (strcmp(s,"all") == 0) {
1898             all = TRUE;
1899             --count;
1900         } else
1901             browseit(findModule(findText(s)),s,all);
1902     if (count == 0) {
1903         browseit(currentModule,NULL,all);
1904     }
1905 }
1906
1907 #if EXPLAIN_INSTANCE_RESOLUTION
1908 static Void local xplain() {         /* print type of expression (if any)*/
1909     Cell d;
1910     Bool sir = showInstRes;
1911
1912     setCurrModule(findEvalModule());
1913     startNewScript(0);                 /* Enables recovery of storage      */
1914                                        /* allocated during evaluation      */
1915     parseContext();
1916     checkContext();
1917     showInstRes = TRUE;
1918     d = provePred(NIL,NIL,hd(inputContext));
1919     if (isNull(d)) {
1920         fprintf(stdout, "not Sat\n");
1921     } else {
1922         fprintf(stdout, "Sat\n");
1923     }
1924     showInstRes = sir;
1925 }
1926 #endif
1927
1928 /* --------------------------------------------------------------------------
1929  * Enhanced help system:  print current list of scripts or give information
1930  * about an object.
1931  * ------------------------------------------------------------------------*/
1932
1933 static String local objToStr(m,c)
1934 Module m;
1935 Cell   c; {
1936 #if 1 || DISPLAY_QUANTIFIERS
1937     static char newVar[60];
1938     switch (whatIs(c)) {
1939         case NAME  : if (m == name(c).mod) {
1940                          sprintf(newVar,"%s", textToStr(name(c).text));
1941                      } else {
1942                          sprintf(newVar,"%s.%s",
1943                                         textToStr(module(name(c).mod).text),
1944                                         textToStr(name(c).text));
1945                      }
1946                      break;
1947
1948         case TYCON : if (m == tycon(c).mod) {
1949                          sprintf(newVar,"%s", textToStr(tycon(c).text));
1950                      } else {
1951                          sprintf(newVar,"%s.%s",
1952                                         textToStr(module(tycon(c).mod).text),
1953                                         textToStr(tycon(c).text));
1954                      }
1955                      break;
1956
1957         case CLASS : if (m == cclass(c).mod) {
1958                          sprintf(newVar,"%s", textToStr(cclass(c).text));
1959                      } else {
1960                          sprintf(newVar,"%s.%s",
1961                                         textToStr(module(cclass(c).mod).text),
1962                                         textToStr(cclass(c).text));
1963                      }
1964                      break;
1965
1966         default    : internal("objToStr");
1967     }
1968     return newVar;
1969 #else
1970     static char newVar[33];
1971     switch (whatIs(c)) {
1972         case NAME  : sprintf(newVar,"%s", textToStr(name(c).text));
1973                      break;
1974
1975         case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1976                      break;
1977
1978         case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1979                      break;
1980
1981         default    : internal("objToStr");
1982     }
1983     return newVar;
1984 #endif
1985 }
1986
1987 extern Name nameHw;
1988
1989 static Void dumpStg ( void )
1990 {
1991    String s;
1992    Int i;
1993 #if 0
1994    Whats this for?
1995    setCurrModule(findEvalModule());
1996    startNewScript(0);
1997 #endif
1998    s = readFilename();
1999
2000    /* request to locate a symbol by name */
2001    if (s && (*s == '?')) {
2002       Text t = findText(s+1);
2003       locateSymbolByName(t);
2004       return;
2005    }
2006
2007    /* request to dump a bit of the heap */
2008    if (s && (*s == '-' || isdigit(*s))) {
2009       int i = atoi(s);
2010       print(i,100);
2011       printf("\n");
2012       return;
2013    }
2014
2015    /* request to dump a symbol table entry */
2016    if (!s
2017        || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
2018        || !isdigit(s[1])) {
2019       fprintf(stderr, ":d -- bad request `%s'\n", s );
2020       return;
2021    }
2022    i = atoi(s+1);
2023    switch (*s) {
2024       case 't': dumpTycon(i); break;
2025       case 'n': dumpName(i); break;
2026       case 'c': dumpClass(i); break;
2027       case 'i': dumpInst(i); break;
2028       default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
2029    }
2030 }
2031
2032
2033 #if 0
2034 static Void local dumpStg( void ) {       /* print STG stuff                 */
2035     String s;
2036     Text   t;
2037     Name   n;
2038     Int    i;
2039     Cell   v;                           /* really StgVar */
2040     setCurrModule(findEvalModule());
2041     startNewScript(0);
2042     for (; (s=readFilename())!=0;) {
2043         t = findText(s);
2044         v = n = NIL;
2045         /* find the name while ignoring module scopes */
2046         for (i=NAMEMIN; i<nameHw; i++)
2047            if (name(i).text == t) n = i;
2048
2049         /* perhaps it's an "idNNNNNN" thing? */
2050         if (isNull(n) &&
2051             strlen(s) >= 3 &&
2052             s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
2053            v = 0;
2054            i = 2;
2055            while (isdigit(s[i])) {
2056               v = v * 10 + (s[i]-'0');
2057               i++;
2058            }
2059            v = -v;
2060            n = nameFromStgVar(v);
2061         }
2062
2063         if (isNull(n) && whatIs(v)==STGVAR) {
2064            Printf ( "\n{- `%s' has no nametable entry -}\n", s );
2065            printStg(stderr, v );
2066         } else
2067         if (isNull(n)) {
2068            Printf ( "Unknown reference `%s'\n", s );
2069         } else
2070         if (!isName(n)) {
2071            Printf ( "Not a Name: `%s'\n", s );
2072         } else
2073         if (isNull(name(n).stgVar)) {
2074            Printf ( "Doesn't have a STG tree: %s\n", s );
2075         } else {
2076            Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
2077            printStg(stderr, name(n).stgVar);
2078         }
2079     }
2080 }
2081 #endif
2082
2083 static Void local info() {              /* describe objects                */
2084     Int    count = 0;                   /* or give menu of commands        */
2085     String s;
2086
2087     for (; (s=readFilename())!=0; count++) {
2088         describe(findText(s));
2089     }
2090     if (count == 0) {
2091        /* whatScripts(); */
2092     }
2093 }
2094
2095
2096 static Void local describe(t)           /* describe an object              */
2097 Text t; {
2098     Tycon  tc  = findTycon(t);
2099     Class  cl  = findClass(t);
2100     Name   nm  = findName(t);
2101
2102     if (nonNull(tc)) {                  /* as a type constructor           */
2103         Type t = tc;
2104         Int  i;
2105         Inst in;
2106         for (i=0; i<tycon(tc).arity; ++i) {
2107             t = ap(t,mkOffset(i));
2108         }
2109         Printf("-- type constructor");
2110         if (kindExpert) {
2111             Printf(" with kind ");
2112             printKind(stdout,tycon(tc).kind);
2113         }
2114         Putchar('\n');
2115         switch (tycon(tc).what) {
2116             case SYNONYM      : Printf("type ");
2117                                 printType(stdout,t);
2118                                 Printf(" = ");
2119                                 printType(stdout,tycon(tc).defn);
2120                                 break;
2121
2122             case NEWTYPE      :
2123             case DATATYPE     : {   List cs = tycon(tc).defn;
2124                                     if (tycon(tc).what==DATATYPE) {
2125                                         Printf("data ");
2126                                     } else {
2127                                         Printf("newtype ");
2128                                     }
2129                                     printType(stdout,t);
2130                                     Putchar('\n');
2131                                     mapProc(printSyntax,cs);
2132                                     if (hasCfun(cs)) {
2133                                         Printf("\n-- constructors:");
2134                                     }
2135                                     for (; hasCfun(cs); cs=tl(cs)) {
2136                                         Putchar('\n');
2137                                         printExp(stdout,hd(cs));
2138                                         Printf(" :: ");
2139                                         printType(stdout,name(hd(cs)).type);
2140                                     }
2141                                     if (nonNull(cs)) {
2142                                         Printf("\n-- selectors:");
2143                                     }
2144                                     for (; nonNull(cs); cs=tl(cs)) {
2145                                         Putchar('\n');
2146                                         printExp(stdout,hd(cs));
2147                                         Printf(" :: ");
2148                                         printType(stdout,name(hd(cs)).type);
2149                                     }
2150                                 }
2151                                 break;
2152
2153             case RESTRICTSYN  : Printf("type ");
2154                                 printType(stdout,t);
2155                                 Printf(" = <restricted>");
2156                                 break;
2157         }
2158         Putchar('\n');
2159         if (nonNull(in=findFirstInst(tc))) {
2160             Printf("\n-- instances:\n");
2161             do {
2162                 showInst(in);
2163                 in = findNextInst(tc,in);
2164             } while (nonNull(in));
2165         }
2166         Putchar('\n');
2167     }
2168
2169     if (nonNull(cl)) {                  /* as a class                      */
2170         List  ins = cclass(cl).instances;
2171         Kinds ks  = cclass(cl).kinds;
2172         if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
2173             Printf("-- type class");
2174         } else {
2175             Printf("-- constructor class");
2176             if (kindExpert) {
2177                 Printf(" with arity ");
2178                 printKinds(stdout,ks);
2179             }
2180         }
2181         Putchar('\n');
2182         mapProc(printSyntax,cclass(cl).members);
2183         Printf("class ");
2184         if (nonNull(cclass(cl).supers)) {
2185             printContext(stdout,cclass(cl).supers);
2186             Printf(" => ");
2187         }
2188         printPred(stdout,cclass(cl).head);
2189
2190         if (nonNull(cclass(cl).fds)) {
2191             List   fds = cclass(cl).fds;
2192             String pre = " | ";
2193             for (; nonNull(fds); fds=tl(fds)) {
2194                 Printf(pre);
2195                 printFD(stdout,hd(fds));
2196                 pre = ", ";
2197             }
2198         }
2199
2200         if (nonNull(cclass(cl).members)) {
2201             List ms = cclass(cl).members;
2202             Printf(" where");
2203             do {
2204                 Type t = name(hd(ms)).type;
2205                 if (isPolyType(t)) {
2206                     t = monotypeOf(t);
2207                 }
2208                 Printf("\n  ");
2209                 printExp(stdout,hd(ms));
2210                 Printf(" :: ");
2211                 if (isNull(tl(fst(snd(t))))) {
2212                     t = snd(snd(t));
2213                 } else {
2214                     t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
2215                 }
2216                 printType(stdout,t);
2217                 ms = tl(ms);
2218             } while (nonNull(ms));
2219         }
2220         Putchar('\n');
2221         if (nonNull(ins)) {
2222             Printf("\n-- instances:\n");
2223             do {
2224                 showInst(hd(ins));
2225                 ins = tl(ins);
2226             } while (nonNull(ins));
2227         }
2228         Putchar('\n');
2229     }
2230
2231     if (nonNull(nm)) {                  /* as a function/name              */
2232         printSyntax(nm);
2233         printExp(stdout,nm);
2234         Printf(" :: ");
2235         if (nonNull(name(nm).type)) {
2236             printType(stdout,name(nm).type);
2237         } else {
2238             Printf("<unknown type>");
2239         }
2240         if (isCfun(nm)) {
2241             Printf("  -- data constructor");
2242         } else if (isMfun(nm)) {
2243             Printf("  -- class member");
2244         } else if (isSfun(nm)) {
2245             Printf("  -- selector function");
2246         }
2247         Printf("\n\n");
2248     }
2249
2250
2251     if (isNull(tc) && isNull(cl) && isNull(nm)) {
2252         Printf("Unknown reference `%s'\n",textToStr(t));
2253     }
2254 }
2255
2256 static Void local printSyntax(nm)
2257 Name nm; {
2258     Syntax sy = syntaxOf(nm);
2259     Text   t  = name(nm).text;
2260     String s  = textToStr(t);
2261     if (sy != defaultSyntax(t)) {
2262         Printf("infix");
2263         switch (assocOf(sy)) {
2264             case LEFT_ASS  : Putchar('l'); break;
2265             case RIGHT_ASS : Putchar('r'); break;
2266             case NON_ASS   : break;
2267         }
2268         Printf(" %i ",precOf(sy));
2269         if (isascii((int)(*s)) && isalpha((int)(*s))) {
2270             Printf("`%s`",s);
2271         } else {
2272             Printf("%s",s);
2273         }
2274         Putchar('\n');
2275     }
2276 }
2277
2278 static Void local showInst(in)          /* Display instance decl header    */
2279 Inst in; {
2280     Printf("instance ");
2281     if (nonNull(inst(in).specifics)) {
2282         printContext(stdout,inst(in).specifics);
2283         Printf(" => ");
2284     }
2285     printPred(stdout,inst(in).head);
2286     Putchar('\n');
2287 }
2288
2289 /* --------------------------------------------------------------------------
2290  * List all names currently in scope:
2291  * ------------------------------------------------------------------------*/
2292
2293 static Void local listNames() {         /* list names matching optional pat*/
2294     String pat   = readFilename();
2295     List   names = NIL;
2296     Int    width = getTerminalWidth() - 1;
2297     Int    count = 0;
2298     Int    termPos;
2299     Module mod   = currentModule;
2300
2301     if (pat) {                          /* First gather names to list      */
2302         do {
2303             names = addNamesMatching(pat,names);
2304         } while ((pat=readFilename())!=0);
2305     } else {
2306         names = addNamesMatching((String)0,names);
2307     }
2308     if (isNull(names)) {                /* Then print them out             */
2309         clearCurrentFile();
2310         ERRMSG(0) "No names selected"
2311         EEND_NO_LONGJMP;
2312         return;
2313     }
2314     for (termPos=0; nonNull(names); names=tl(names)) {
2315         String s = objToStr(mod,hd(names));
2316         Int    l = strlen(s);
2317         if (termPos+1+l>width) {
2318             Putchar('\n');
2319             termPos = 0;
2320         } else if (termPos>0) {
2321             Putchar(' ');
2322             termPos++;
2323         }
2324         Printf("%s",s);
2325         termPos += l;
2326         count++;
2327     }
2328     Printf("\n(%d names listed)\n", count);
2329 }
2330
2331 /* --------------------------------------------------------------------------
2332  * print a prompt and read a line of input:
2333  * ------------------------------------------------------------------------*/
2334
2335 static Void local promptForInput(moduleName)
2336 String moduleName; {
2337     char promptBuffer[1000];
2338 #if 1
2339     /* This is portable but could overflow buffer */
2340     sprintf(promptBuffer,prompt,moduleName);
2341 #else
2342     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
2343      * promptBuffer instead.
2344      */
2345     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
2346         /* Reset prompt to a safe default to avoid an infinite loop */
2347         free(prompt);
2348         prompt = strCopy("? ");
2349         internal("Combined prompt and evaluation module name too long");
2350     }
2351 #endif
2352     if (autoMain)
2353        stringInput("main\0"); else
2354        consoleInput(promptBuffer);
2355 }
2356
2357 /* --------------------------------------------------------------------------
2358  * main read-eval-print loop, with error trapping:
2359  * ------------------------------------------------------------------------*/
2360
2361 static Void local interpreter(argc,argv)/* main interpreter loop           */
2362 Int    argc;
2363 String argv[]; {
2364
2365     List   modConIds; /* :: [CONID] */
2366     Bool   prelOK;
2367     String s;
2368
2369     setBreakAction ( HugsIgnoreBreak );
2370     modConIds = initialize(argc,argv);  /* the initial modules to load     */
2371     setBreakAction ( HugsIgnoreBreak );
2372     prelOK    = loadThePrelude();
2373
2374     if (!prelOK) {
2375        if (autoMain)
2376           fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
2377        else
2378           fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
2379        exit(1);
2380     }
2381
2382     if (combined) everybody(POSTPREL);
2383     loadActions(modConIds);
2384
2385     if (autoMain) {
2386        for (; nonNull(modConIds); modConIds=tl(modConIds))
2387           if (!elemMG(hd(modConIds))) {
2388              fprintf(stderr,
2389                      "hugs +Q: compilation failed -- can't run `main'\n" );
2390              exit(1);
2391           }
2392     }
2393
2394     modConIds = NIL;
2395
2396     /* initialize calls startupHaskell, which trashes our signal handlers */
2397     setBreakAction ( HugsIgnoreBreak );
2398     forHelp();
2399
2400     for (;;) {
2401         Command cmd;
2402         everybody(RESET);               /* reset to sensible initial state */
2403
2404         promptForInput(textToStr(module(currentModule).text));
2405
2406         cmd = readCommand(cmds, (Char)':', (Char)'!');
2407         switch (cmd) {
2408             case EDIT   : editor();
2409                           break;
2410             case FIND   : find();
2411                           break;
2412             case LOAD   : modConIds = NIL;
2413                 while ((s=readFilename())!=0) {
2414                           modConIds = cons(mkCon(findText(s)),modConIds);
2415
2416                 }
2417                           loadActions(modConIds);
2418                           modConIds = NIL;
2419                           break;
2420             case ALSO   : modConIds = NIL;
2421                           while ((s=readFilename())!=0)
2422                              modConIds = cons(mkCon(findText(s)),modConIds);
2423                           addActions(modConIds);
2424                           modConIds = NIL;
2425                           break;
2426             case RELOAD : refreshActions(NIL,FALSE);
2427                           break;
2428             case SETMODULE :
2429                           setModule();
2430                           break;
2431             case EVAL   : evaluator();
2432                           break;
2433             case TYPEOF : showtype();
2434                           break;
2435             case BROWSE : browse();
2436                           break;
2437 #if EXPLAIN_INSTANCE_RESOLUTION
2438             case XPLAIN : xplain();
2439                           break;
2440 #endif
2441             case NAMES  : listNames();
2442                           break;
2443             case HELP   : menu();
2444                           break;
2445             case BADCMD : guidance();
2446                           break;
2447             case SET    : set();
2448                           break;
2449             case SYSTEM : if (shellEsc(readLine()))
2450                               Printf("Warning: Shell escape terminated abnormally\n");
2451                           break;
2452             case CHGDIR : changeDir();
2453                           break;
2454             case INFO   : info();
2455                           break;
2456             case PNTVER: Printf("-- Hugs Version %s\n",
2457                                  HUGS_VERSION);
2458                           break;
2459             case DUMP   : dumpStg();
2460                           break;
2461             case QUIT   : return;
2462             case COLLECT: consGC = FALSE;
2463                           garbageCollect();
2464                           consGC = TRUE;
2465                           Printf("Garbage collection recovered %d cells\n",
2466                                  cellsRecovered);
2467                           break;
2468             case NOCMD  : break;
2469         }
2470
2471         if (autoMain) break;
2472     }
2473 }
2474
2475 /* --------------------------------------------------------------------------
2476  * Display progress towards goal:
2477  * ------------------------------------------------------------------------*/
2478
2479 static Target currTarget;
2480 static Bool   aiming = FALSE;
2481 static Int    currPos;
2482 static Int    maxPos;
2483 static Int    charCount;
2484
2485 Void setGoal(what, t)                  /* Set goal for what to be t        */
2486 String what;
2487 Target t; {
2488     if (quiet)
2489       return;
2490 #if EXPLAIN_INSTANCE_RESOLUTION
2491     if (showInstRes)
2492       return;
2493 #endif
2494     currTarget = (t?t:1);
2495     aiming     = TRUE;
2496     if (useDots) {
2497         currPos = strlen(what);
2498         maxPos  = getTerminalWidth() - 1;
2499         Printf("%s",what);
2500     }
2501     else
2502         for (charCount=0; *what; charCount++)
2503             Putchar(*what++);
2504     FlushStdout();
2505 }
2506
2507 Void soFar(t)                          /* Indicate progress towards goal   */
2508 Target t; {                            /* has now reached t                */
2509     if (quiet)
2510       return;
2511 #if EXPLAIN_INSTANCE_RESOLUTION
2512     if (showInstRes)
2513       return;
2514 #endif
2515     if (useDots) {
2516         Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2517
2518         if (newPos>maxPos)
2519             newPos = maxPos;
2520
2521         if (newPos>currPos) {
2522             do
2523                 Putchar('.');
2524             while (newPos>++currPos);
2525             FlushStdout();
2526         }
2527         FlushStdout();
2528     }
2529 }
2530
2531 Void done() {                          /* Goal has now been achieved       */
2532     if (quiet)
2533       return;
2534 #if EXPLAIN_INSTANCE_RESOLUTION
2535     if (showInstRes)
2536       return;
2537 #endif
2538     if (useDots) {
2539         while (maxPos>currPos++)
2540             Putchar('.');
2541         Putchar('\n');
2542     }
2543     else
2544         for (; charCount>0; charCount--) {
2545             Putchar('\b');
2546             Putchar(' ');
2547             Putchar('\b');
2548         }
2549     aiming = FALSE;
2550     FlushStdout();
2551 }
2552
2553 static Void local failed() {           /* Goal cannot be reached due to    */
2554     if (aiming) {                      /* errors                           */
2555         aiming = FALSE;
2556         Putchar('\n');
2557         FlushStdout();
2558     }
2559 }
2560
2561 /* --------------------------------------------------------------------------
2562  * Error handling:
2563  * ------------------------------------------------------------------------*/
2564
2565 static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
2566     if (printing) {                    /* after successful termination or  */
2567         printing = FALSE;              /* runtime error (e.g. interrupt)   */
2568         Putchar('\n');
2569         if (showStats) {
2570 #define plural(v)   v, (v==1?"":"s")
2571             Printf("(%lu enter%s)\n",plural(numEnters));
2572 #undef plural
2573         }
2574         FlushStdout();
2575         garbageCollect();
2576     }
2577 }
2578
2579 Cell errAssert(l)   /* message to use when raising asserts, etc */
2580 Int l; {
2581   Cell str;
2582   if (currentFile) {
2583     str = mkStr(findText(currentFile));
2584   } else {
2585     str = mkStr(findText(""));
2586   }
2587   return (ap2(nameTangleMessage,str,mkInt(l)));
2588 }
2589
2590 Void errHead(l)                        /* print start of error message     */
2591 Int l; {
2592     failed();                          /* failed to reach target ...       */
2593     stopAnyPrinting();
2594     FPrintf(errorStream,"ERROR");
2595
2596     if (currentFile) {
2597         FPrintf(errorStream," \"%s\"", currentFile);
2598         setLastEdit(currentFile,l);
2599         if (l) FPrintf(errorStream," (line %d)",l);
2600         currentFile = NULL;
2601     }
2602     FPrintf(errorStream,": ");
2603     FFlush(errorStream);
2604 }
2605
2606 Void errFail() {                        /* terminate error message and     */
2607     Putc('\n',errorStream);             /* produce exception to return to  */
2608     FFlush(errorStream);                /* main command loop               */
2609     longjmp(catch_error,1);
2610 }
2611
2612 Void errFail_no_longjmp() {             /* terminate error message but     */
2613     Putc('\n',errorStream);             /* don't produce an exception      */
2614     FFlush(errorStream);
2615 }
2616
2617 Void errAbort() {                       /* altern. form of error handling  */
2618     failed();                           /* used when suitable error message*/
2619     stopAnyPrinting();                  /* has already been printed        */
2620     errFail();
2621 }
2622
2623 Void internal(msg)                      /* handle internal error           */
2624 String msg; {
2625     failed();
2626     stopAnyPrinting();
2627     Printf("INTERNAL ERROR: %s\n",msg);
2628     FlushStdout();
2629 exit(9);
2630     longjmp(catch_error,1);
2631 }
2632
2633 Void fatal(msg)                         /* handle fatal error              */
2634 String msg; {
2635     FlushStdout();
2636     Printf("\nFATAL ERROR: %s\n",msg);
2637     everybody(EXIT);
2638     exit(1);
2639 }
2640
2641
2642 /* --------------------------------------------------------------------------
2643  * Read value from environment variable or registry:
2644  * ------------------------------------------------------------------------*/
2645
2646 String fromEnv(var,def)         /* return value of:                        */
2647 String var;                     /*     environment variable named by var   */
2648 String def; {                   /* or: default value given by def          */
2649     String s = getenv(var);
2650     return (s ? s : def);
2651 }
2652
2653 /* --------------------------------------------------------------------------
2654  * String manipulation routines:
2655  * ------------------------------------------------------------------------*/
2656
2657 static String local strCopy(s)         /* make malloced copy of a string   */
2658 String s; {
2659     if (s && *s) {
2660         char *t, *r;
2661         if ((t=(char *)malloc(strlen(s)+1))==0) {
2662             ERRMSG(0) "String storage space exhausted"
2663             EEND;
2664         }
2665         for (r=t; (*r++ = *s++)!=0; ) {
2666         }
2667         return t;
2668     }
2669     return NULL;
2670 }
2671
2672
2673 /* --------------------------------------------------------------------------
2674  * Compiler output
2675  * We can redirect compiler output (prompts, error messages, etc) by
2676  * tweaking these functions.
2677  * ------------------------------------------------------------------------*/
2678
2679 #ifdef HAVE_STDARG_H
2680 #include <stdarg.h>
2681 #else
2682 #include <varargs.h>
2683 #endif
2684
2685 Void hugsEnableOutput(f)
2686 Bool f; {
2687     disableOutput = !f;
2688 }
2689
2690 #ifdef HAVE_STDARG_H
2691 Void hugsPrintf(const char *fmt, ...) {
2692     va_list ap;                    /* pointer into argument list           */
2693     va_start(ap, fmt);             /* make ap point to first arg after fmt */
2694     if (!disableOutput) {
2695         vprintf(fmt, ap);
2696     } else {
2697     }
2698     va_end(ap);                    /* clean up                             */
2699 }
2700 #else
2701 Void hugsPrintf(fmt, va_alist)
2702 const char *fmt;
2703 va_dcl {
2704     va_list ap;                    /* pointer into argument list           */
2705     va_start(ap);                  /* make ap point to first arg after fmt */
2706     if (!disableOutput) {
2707         vprintf(fmt, ap);
2708     } else {
2709     }
2710     va_end(ap);                    /* clean up                             */
2711 }
2712 #endif
2713
2714 Void hugsPutchar(c)
2715 int c; {
2716     if (!disableOutput) {
2717         putchar(c);
2718     } else {
2719     }
2720 }
2721
2722 Void hugsFlushStdout() {
2723     if (!disableOutput) {
2724         fflush(stdout);
2725     }
2726 }
2727
2728 Void hugsFFlush(fp)
2729 FILE* fp; {
2730     if (!disableOutput) {
2731         fflush(fp);
2732     }
2733 }
2734
2735 #ifdef HAVE_STDARG_H
2736 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2737     va_list ap;
2738     va_start(ap, fmt);
2739     if (!disableOutput) {
2740         vfprintf(fp, fmt, ap);
2741     } else {
2742     }
2743     va_end(ap);
2744 }
2745 #else
2746 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2747 FILE* fp;
2748 const char* fmt;
2749 va_dcl {
2750     va_list ap;
2751     va_start(ap);
2752     if (!disableOutput) {
2753         vfprintf(fp, fmt, ap);
2754     } else {
2755     }
2756     va_end(ap);
2757 }
2758 #endif
2759
2760 Void hugsPutc(c, fp)
2761 int   c;
2762 FILE* fp; {
2763     if (!disableOutput) {
2764         putc(c,fp);
2765     } else {
2766     }
2767 }
2768
2769 /* --------------------------------------------------------------------------
2770  * Send message to each component of system:
2771  * ------------------------------------------------------------------------*/
2772
2773 Void everybody(what)            /* send command `what' to each component of*/
2774 Int what; {                     /* system to respond as appropriate ...    */
2775 #if 0
2776   fprintf ( stderr, "EVERYBODY %d\n", what );
2777 #endif
2778     machdep(what);              /* The order of calling each component is  */
2779     storage(what);              /* important for the PREPREL command       */
2780     substitution(what);
2781     input(what);
2782     translateControl(what);
2783     linkControl(what);
2784     staticAnalysis(what);
2785     deriveControl(what);
2786     typeChecker(what);
2787     compiler(what);
2788     codegen(what);
2789
2790     if (what == MARK) {
2791        mark(moduleGraph);
2792        mark(prelModules);
2793        mark(targetModules);
2794        mark(daSccs);
2795        mark(currentModule_failed);
2796     }
2797 }
2798
2799 /*-------------------------------------------------------------------------*/