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