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.21 $
  13  * $Date: 1999/11/17 16:57:38 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include <setjmp.h>
  17 #include <ctype.h>
  18 #include <stdio.h>
  19
  20 #include "prelude.h"
  21 #include "storage.h"
  22 #include "command.h"
  23 #include "backend.h"
  24 #include "connect.h"
  25 #include "errors.h"
  26 #include "version.h"
  27 #include "link.h"
  28
  29 #include "Rts.h"
  30 #include "RtsAPI.h"
  31 #include "Schedule.h"
  32
  33
  34 Bool haskell98 = TRUE;                  /* TRUE => Haskell 98 compatibility*/
  35
  36 #if EXPLAIN_INSTANCE_RESOLUTION
  37 Bool showInstRes = FALSE;
  38 #endif
  39 #if MULTI_INST
  40 Bool multiInstRes = FALSE;
  41 #endif
  42
  43 /* --------------------------------------------------------------------------
  44  * Local function prototypes:
  45  * ------------------------------------------------------------------------*/
  46
  47 static Void   local initialize        Args((Int,String []));
  48 static Void   local promptForInput    Args((String));
  49 static Void   local interpreter       Args((Int,String []));
  50 static Void   local menu              Args((Void));
  51 static Void   local guidance          Args((Void));
  52 static Void   local forHelp           Args((Void));
  53 static Void   local set               Args((Void));
  54 static Void   local changeDir         Args((Void));
  55 static Void   local load              Args((Void));
  56 static Void   local project           Args((Void));
  57 static Void   local readScripts       Args((Int));
  58 static Void   local whatScripts       Args((Void));
  59 static Void   local editor            Args((Void));
  60 static Void   local find              Args((Void));
  61 static Bool   local startEdit         Args((Int,String));
  62 static Void   local runEditor         Args((Void));
  63 static Void   local setModule         Args((Void));
  64 static Module local findEvalModule    Args((Void));
  65 static Void   local evaluator         Args((Void));
  66 static Void   local stopAnyPrinting   Args((Void));
  67 static Void   local showtype          Args((Void));
  68 static String local objToStr          Args((Module, Cell));
  69 static Void   local info              Args((Void));
  70 static Void   local printSyntax       Args((Name));
  71 static Void   local showInst          Args((Inst));
  72 static Void   local describe          Args((Text));
  73 static Void   local listNames         Args((Void));
  74
  75 static Void   local toggleSet         Args((Char,Bool));
  76 static Void   local togglesIn         Args((Bool));
  77 static Void   local optionInfo        Args((Void));
  78 #if USE_REGISTRY || HUGS_FOR_WINDOWS
  79 static String local optionsToStr      Args((Void));
  80 #endif
  81 static Void   local readOptions       Args((String));
  82 static Bool   local processOption     Args((String));
  83 static Void   local setHeapSize       Args((String));
  84 static Int    local argToInt          Args((String));
  85
  86 static Void   local loadProject       Args((String));
  87 static Void   local clearProject      Args((Void));
  88 static Bool   local addScript         Args((Int));
  89 static Void   local forgetScriptsFrom Args((Script));
  90 static Void   local setLastEdit       Args((String,Int));
  91 static Void   local failed            Args((Void));
  92 static String local strCopy           Args((String));
  93 static Void   local browseit          Args((Module,String,Bool));
  94 static Void   local browse            Args((Void));
  95
  96 /* --------------------------------------------------------------------------
  97  * Machine dependent code for Hugs interpreter:
  98  * ------------------------------------------------------------------------*/
  99
 100 #include "machdep.c"
 101 #ifdef WANT_TIMER
 102 #include "timer.c"
 103 #endif
 104
 105 /* --------------------------------------------------------------------------
 106  * Local data areas:
 107  * ------------------------------------------------------------------------*/
 108
 109 static Bool   printing     = FALSE;     /* TRUE => currently printing value*/
 110 static Bool   showStats    = FALSE;     /* TRUE => print stats after eval  */
 111 static Bool   listScripts  = TRUE;      /* TRUE => list scripts after loading*/
 112 static Bool   addType      = FALSE;     /* TRUE => print type with value   */
 113 static Bool   useDots      = RISCOS;    /* TRUE => use dots in progress    */
 114 static Bool   quiet        = FALSE;     /* TRUE => don't show progress     */
 115 static Bool   lastWasObject = FALSE;
 116        Bool   preludeLoaded = FALSE;
 117
 118 typedef
 119    struct {
 120       String modName;                   /* Module name                     */
 121       Bool   details;             /* FALSE => remaining fields are invalid */
 122       String path;                      /* Path to module                  */
 123       String srcExt;                    /* ".hs" or ".lhs" if fromSource   */
 124       Time   lastChange;                /* Time of last change to script   */
 125       Bool   fromSource;                /* FALSE => load object code       */
 126       Bool   postponed;                 /* Indicates postponed load        */
 127       Bool   objLoaded;
 128       Long   size;
 129       Long   oSize;
 130    }
 131    ScriptInfo;
 132
 133 static Void   local makeStackEntry    Args((ScriptInfo*,String));
 134 static Void   local addStackEntry     Args((String));
 135
 136 static ScriptInfo scriptInfo[NUM_SCRIPTS];
 137
 138 static Int    numScripts;               /* Number of scripts loaded        */
 139 static Int    nextNumScripts;
 140 static Int    namesUpto;                /* Number of script names set      */
 141 static Bool   needsImports;             /* set to TRUE if imports required */
 142        String scriptFile;               /* Name of current script (if any) */
 143
 144
 145
 146 static Text   evalModule  = 0;          /* Name of module we eval exprs in */
 147 static String currProject = 0;          /* Name of current project file    */
 148 static Bool   projectLoaded = FALSE;    /* TRUE => project file loaded     */
 149
 150 static Bool   autoMain   = FALSE;
 151 static String lastEdit   = 0;           /* Name of script to edit (if any) */
 152 static Int    lastEdLine = 0;           /* Editor line number (if possible)*/
 153 static String prompt     = 0;           /* Prompt string                   */
 154 static Int    hpSize     = DEFAULTHEAP; /* Desired heap size               */
 155        String hugsEdit   = 0;           /* String for editor command       */
 156        String hugsPath   = 0;           /* String for file search path     */
 157
 158 #if REDIRECT_OUTPUT
 159 static Bool disableOutput = FALSE;      /* redirect output to buffer?      */
 160 #endif
 161
 162 String bool2str ( Bool b )
 163 {
 164    if (b) return "Yes"; else return "No ";
 165 }
 166
 167 void ppSmStack ( String who )
 168 {
 169    int i, j;
 170 return;
 171    fflush(stdout);fflush(stderr);
 172    printf ( "\n" );
 173    printf ( "ppSmStack %s:  numScripts = %d   namesUpto = %d  needsImports = %s\n",
 174             who, numScripts, namesUpto, bool2str(needsImports) );
 175    assert (namesUpto >= numScripts);
 176    printf ( "     Det FrS Pst ObL           Module Ext   Size ModTime  Path\n" );
 177    for (i = namesUpto-1; i >= 0; i--) {
 178       printf ( "%c%2d: %3s %3s %3s %3s %16s %-4s %5ld %8lx %s\n",
 179                (i==numScripts ? '*' : ' '),
 180                i, bool2str(scriptInfo[i].details),
 181                   bool2str(scriptInfo[i].fromSource),
 182                   bool2str(scriptInfo[i].postponed),
 183                   bool2str(scriptInfo[i].objLoaded),
 184                   scriptInfo[i].modName,
 185                   scriptInfo[i].fromSource ? scriptInfo[i].srcExt : "",
 186                   scriptInfo[i].size,
 187                   scriptInfo[i].lastChange,
 188                   scriptInfo[i].path
 189              );
 190    }
 191    fflush(stdout);fflush(stderr);
 192    ppScripts();
 193    ppModules();
 194    printf ( "\n" );
 195 }
 196
 197 /* --------------------------------------------------------------------------
 198  * Hugs entry point:
 199  * ------------------------------------------------------------------------*/
 200
 201 #ifndef NO_MAIN /* we omit main when building the "Hugs server" */
 202
 203 Main main Args((Int, String []));       /* now every func has a prototype  */
 204
 205 Main main(argc,argv)
 206 int  argc;
 207 char *argv[]; {
 208 #ifdef HAVE_CONSOLE_H /* Macintosh port */
 209     _ftype = 'TEXT';
 210     _fcreator = 'R*ch';       /*  // 'KAHL';      //'*TEX';       //'ttxt'; */
 211
 212     console_options.top = 50;
 213     console_options.left = 20;
 214
 215     console_options.nrows = 32;
 216     console_options.ncols = 80;
 217
 218     console_options.pause_atexit = 1;
 219     console_options.title = "\pHugs";
 220
 221     console_options.procID = 5;
 222     argc = ccommand(&argv);
 223 #endif
 224
 225     CStackBase = &argc;                 /* Save stack base for use in gc   */
 226
 227     /* Try and figure out an absolute path to the executable, so
 228        we can make a reasonable guess about where the default
 229        libraries (Prelude etc) are.
 230     */
 231     setDefaultLibDir ( argv[0] );
 232
 233     /* If first arg is +Q or -Q, be entirely silent, and automatically run
 234        main after loading scripts.  Useful for running the nofib suite.    */
 235     if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
 236        autoMain = TRUE;
 237        hugsEnableOutput(0);
 238     }
 239
 240     Printf("__   __ __  __  ____   ___      _________________________________________\n");
 241     Printf("||   || ||  || ||  || ||__      Hugs 98: Based on the Haskell 98 standard\n");
 242     Printf("||___|| ||__|| ||__||  __||     Copyright (c) 1994-1999\n");
 243     Printf("||---||         ___||           World Wide Web: http://haskell.org/hugs\n");
 244     Printf("||   ||                         Report bugs to: hugs-bugs@haskell.org\n");
 245     Printf("||   || Version: %s _________________________________________\n\n",HUGS_VERSION);
 246
 247 #if SYMANTEC_C
 248     Printf("   Ported to Macintosh by Hans Aberg, compiled " __DATE__ ".\n\n");
 249 #endif
 250     FlushStdout();
 251     interpreter(argc,argv);
 252     Printf("[Leaving Hugs]\n");
 253     everybody(EXIT);
 254     shutdownHaskell();
 255     FlushStdout();
 256     fflush(stderr);
 257     exit(0);
 258     MainDone();
 259 }
 260
 261 #endif
 262
 263 /* --------------------------------------------------------------------------
 264  * Initialization, interpret command line args and read prelude:
 265  * ------------------------------------------------------------------------*/
 266
 267 static Void local initialize(argc,argv)/* Interpreter initialization       */
 268 Int    argc;
 269 String argv[]; {
 270     Script i;
 271     String proj        = 0;
 272     char argv_0_orig[1000];
 273
 274     setLastEdit((String)0,0);
 275     lastEdit      = 0;
 276     scriptFile    = 0;
 277     numScripts    = 0;
 278     namesUpto     = 1;
 279
 280 #if HUGS_FOR_WINDOWS
 281     hugsEdit      = strCopy(fromEnv("EDITOR","c:\\windows\\notepad.exe"));
 282 #elif SYMANTEC_C
 283     hugsEdit      = "";
 284 #else
 285     hugsEdit      = strCopy(fromEnv("EDITOR",NULL));
 286 #endif
 287     hugsPath      = strCopy(HUGSPATH);
 288     readOptions("-p\"%s> \" -r$$");
 289 #if USE_REGISTRY
 290     projectPath   = strCopy(readRegChildStrings(HKEY_LOCAL_MACHINE,ProjectRoot,
 291                                                 "HUGSPATH", PATHSEP, ""));
 292     readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
 293     readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
 294 #endif /* USE_REGISTRY */
 295     readOptions(fromEnv("STGHUGSFLAGS",""));
 296
 297    strncpy(argv_0_orig,argv[0],1000);   /* startupHaskell mangles argv[0] */
 298    startupHaskell (argc,argv);
 299    argc = prog_argc; argv = prog_argv;
 300
 301    namesUpto = numScripts = 0;
 302    addStackEntry("Prelude");
 303
 304    for (i=1; i<argc; ++i) {            /* process command line arguments  */
 305         if (strcmp(argv[i], "--")==0) break;
 306         if (strcmp(argv[i],"+")==0 && i+1<argc) {
 307             if (proj) {
 308                 ERRMSG(0) "Multiple project filenames on command line"
 309                 EEND;
 310             } else {
 311                 proj = argv[++i];
 312             }
 313         } else if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/
 314                  && !processOption(argv[i])) {
 315             addStackEntry(argv[i]);
 316         }
 317     }
 318
 319 #if DEBUG
 320     DEBUG_LoadSymbols(argv_0_orig);
 321 #endif
 322
 323
 324 #if 0
 325     if (!scriptName[0]) {
 326         Printf("Prelude not found on current path: \"%s\"\n",
 327                hugsPath ? hugsPath : "");
 328         fatal("Unable to load prelude");
 329     }
 330 #endif
 331
 332     if (haskell98) {
 333         Printf("Haskell 98 mode: Restart with command line option -98 to enable extensions\n\n");
 334     } else {
 335         Printf("Hugs mode: Restart with command line option +98 for Haskell 98 mode\n\n");
 336     }
 337
 338     everybody(INSTALL);
 339     evalModule = findText("");      /* evaluate wrt last module by default */
 340     if (proj) {
 341         if (namesUpto>1) {
 342             fprintf(stderr,
 343                     "\nUsing project file, ignoring additional filenames\n");
 344         }
 345         loadProject(strCopy(proj));
 346     }
 347     readScripts(0);
 348 }
 349
 350 /* --------------------------------------------------------------------------
 351  * Command line options:
 352  * ------------------------------------------------------------------------*/
 353
 354 struct options {                        /* command line option toggles     */
 355     char   c;                           /* table defined in main app.      */
 356     int    h98;
 357     String description;
 358     Bool   *flag;
 359 };
 360 extern struct options toggle[];
 361
 362 static Void local toggleSet(c,state)    /* Set command line toggle         */
 363 Char c;
 364 Bool state; {
 365     Int i;
 366     for (i=0; toggle[i].c; ++i)
 367         if (toggle[i].c == c) {
 368             *toggle[i].flag = state;
 369             return;
 370         }
 371     ERRMSG(0) "Unknown toggle `%c'", c
 372     EEND;
 373 }
 374
 375 static Void local togglesIn(state)      /* Print current list of toggles in*/
 376 Bool state; {                           /* given state                     */
 377     Int count = 0;
 378     Int i;
 379     for (i=0; toggle[i].c; ++i)
 380         if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
 381             if (count==0)
 382                 Putchar((char)(state ? '+' : '-'));
 383             Putchar(toggle[i].c);
 384             count++;
 385         }
 386     if (count>0)
 387         Putchar(' ');
 388 }
 389
 390 static Void local optionInfo() {        /* Print information about command */
 391     static String fmts = "%-5s%s\n";    /* line settings                   */
 392     static String fmtc = "%-5c%s\n";
 393     Int    i;
 394
 395     Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
 396     for (i=0; toggle[i].c; ++i) {
 397         if (!haskell98 || toggle[i].h98) {
 398             Printf(fmtc,toggle[i].c,toggle[i].description);
 399         }
 400     }
 401
 402     Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
 403     Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
 404     Printf(fmts,"pstr","Set prompt string to str");
 405     Printf(fmts,"rstr","Set repeat last expression string to str");
 406     Printf(fmts,"Pstr","Set search path for modules to str");
 407     Printf(fmts,"Estr","Use editor setting given by str");
 408     Printf(fmts,"cnum","Set constraint cutoff limit");
 409 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 410     Printf(fmts,"Fstr","Set preprocessor filter to str");
 411 #endif
 412
 413     Printf("\nCurrent settings: ");
 414     togglesIn(TRUE);
 415     togglesIn(FALSE);
 416     Printf("-h%d",heapSize);
 417     Printf(" -p");
 418     printString(prompt);
 419     Printf(" -r");
 420     printString(repeatStr);
 421     Printf(" -c%d",cutoff);
 422     Printf("\nSearch path     : -P");
 423     printString(hugsPath);
 424 #if 0
 425 ToDo
 426     if (projectPath!=NULL) {
 427         Printf("\nProject Path    : %s",projectPath);
 428     }
 429 #endif
 430     Printf("\nEditor setting  : -E");
 431     printString(hugsEdit);
 432 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 433     Printf("\nPreprocessor    : -F");
 434     printString(preprocessor);
 435 #endif
 436     Printf("\nCompatibility   : %s", haskell98 ? "Haskell 98 (+98)"
 437                                                : "Hugs Extensions (-98)");
 438     Putchar('\n');
 439 }
 440
 441 #if USE_REGISTRY || HUGS_FOR_WINDOWS
 442 #define PUTC(c)                         \
 443     *next++=(c)
 444
 445 #define PUTS(s)                         \
 446     strcpy(next,s);                     \
 447     next+=strlen(next)
 448
 449 #define PUTInt(optc,i)                  \
 450     sprintf(next,"-%c%d",optc,i);       \
 451     next+=strlen(next)
 452
 453 #define PUTStr(c,s)                     \
 454     next=PUTStr_aux(next,c,s)
 455
 456 static String local PUTStr_aux Args((String,Char, String));
 457
 458 static String local PUTStr_aux(next,c,s)
 459 String next;
 460 Char   c;
 461 String s; {
 462     if (s) {
 463         String t = 0;
 464         sprintf(next,"-%c\"",c);
 465         next+=strlen(next);
 466         for(t=s; *t; ++t) {
 467             PUTS(unlexChar(*t,'"'));
 468         }
 469         next+=strlen(next);
 470         PUTS("\" ");
 471     }
 472     return next;
 473 }
 474
 475 static String local optionsToStr() {          /* convert options to string */
 476     static char buffer[2000];
 477     String next = buffer;
 478
 479     Int i;
 480     for (i=0; toggle[i].c; ++i) {
 481         PUTC(*toggle[i].flag ? '+' : '-');
 482         PUTC(toggle[i].c);
 483         PUTC(' ');
 484     }
 485     PUTS(haskell98 ? "+98 " : "-98 ");
 486     PUTInt('h',hpSize);  PUTC(' ');
 487     PUTStr('p',prompt);
 488     PUTStr('r',repeatStr);
 489     PUTStr('P',hugsPath);
 490     PUTStr('E',hugsEdit);
 491     PUTInt('c',cutoff);  PUTC(' ');
 492 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 493     PUTStr('F',preprocessor);
 494 #endif
 495     PUTC('\0');
 496     return buffer;
 497 }
 498 #endif /* USE_REGISTRY */
 499
 500 #undef PUTC
 501 #undef PUTS
 502 #undef PUTInt
 503 #undef PUTStr
 504
 505 static Void local readOptions(options)         /* read options from string */
 506 String options; {
 507     String s;
 508     if (options) {
 509         stringInput(options);
 510         while ((s=readFilename())!=0) {
 511             if (*s && !processOption(s)) {
 512                 ERRMSG(0) "Option string must begin with `+' or `-'"
 513                 EEND;
 514             }
 515         }
 516     }
 517 }
 518
 519 static Bool local processOption(s)      /* process string s for options,   */
 520 String s; {                             /* return FALSE if none found.     */
 521     Bool state;
 522
 523     if (s[0]=='-')
 524         state = FALSE;
 525     else if (s[0]=='+')
 526         state = TRUE;
 527     else
 528         return FALSE;
 529
 530     while (*++s)
 531         switch (*s) {
 532             case 'Q' : break;                           /* already handled */
 533
 534             case 'p' : if (s[1]) {
 535                            if (prompt) free(prompt);
 536                            prompt = strCopy(s+1);
 537                        }
 538                        return TRUE;
 539
 540             case 'r' : if (s[1]) {
 541                            if (repeatStr) free(repeatStr);
 542                            repeatStr = strCopy(s+1);
 543                        }
 544                        return TRUE;
 545
 546             case 'P' : {
 547                            String p = substPath(s+1,hugsPath ? hugsPath : "");
 548                            if (hugsPath) free(hugsPath);
 549                            hugsPath = p;
 550                            return TRUE;
 551                        }
 552
 553             case 'E' : if (hugsEdit) free(hugsEdit);
 554                        hugsEdit = strCopy(s+1);
 555                        return TRUE;
 556
 557 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 558             case 'F' : if (preprocessor) free(preprocessor);
 559                        preprocessor = strCopy(s+1);
 560                        return TRUE;
 561 #endif
 562
 563             case 'h' : setHeapSize(s+1);
 564                        return TRUE;
 565
 566             case 'D' : /* hack */
 567                 {
 568                     extern void setRtsFlags( int x );
 569                     setRtsFlags(argToInt(s+1));
 570                     return TRUE;
 571                 }
 572
 573             default  : if (strcmp("98",s)==0) {
 574                            if (heapBuilt() && ((state && !haskell98) ||
 575                                                (!state && haskell98))) {
 576                                FPrintf(stderr,
 577                                        "Haskell 98 compatibility cannot be changed"
 578                                        " while the interpreter is running\n");
 579                            } else {
 580                                haskell98 = state;
 581                            }
 582                            return TRUE;
 583                        } else {
 584                            toggleSet(*s,state);
 585                        }
 586                        break;
 587         }
 588     return TRUE;
 589 }
 590
 591 static Void local setHeapSize(s)
 592 String s; {
 593     if (s) {
 594         hpSize = argToInt(s);
 595         if (hpSize < MINIMUMHEAP)
 596             hpSize = MINIMUMHEAP;
 597         else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
 598             hpSize = MAXIMUMHEAP;
 599         if (heapBuilt() && hpSize != heapSize) {
 600             /* ToDo: should this use a message box in winhugs? */
 601 #if USE_REGISTRY
 602             FPrintf(stderr,"Change to heap size will not take effect until you rerun Hugs\n");
 603 #else
 604             FPrintf(stderr,"Cannot change heap size\n");
 605 #endif
 606         } else {
 607             heapSize = hpSize;
 608         }
 609     }
 610 }
 611
 612 static Int local argToInt(s)            /* read integer from argument str  */
 613 String s; {
 614     Int    n = 0;
 615     String t = s;
 616
 617     if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
 618         ERRMSG(0) "Missing integer in option setting \"%s\"", t
 619         EEND;
 620     }
 621
 622     do {
 623         Int d = (*s++) - '0';
 624         if (n > ((MAXPOSINT - d)/10)) {
 625             ERRMSG(0) "Option setting \"%s\" is too large", t
 626             EEND;
 627         }
 628         n     = 10*n + d;
 629     } while (isascii((int)(*s)) && isdigit((int)(*s)));
 630
 631     if (*s=='K' || *s=='k') {
 632         if (n > (MAXPOSINT/1000)) {
 633             ERRMSG(0) "Option setting \"%s\" is too large", t
 634             EEND;
 635         }
 636         n *= 1000;
 637         s++;
 638     }
 639
 640 #if MAXPOSINT > 1000000                 /* waste of time on 16 bit systems */
 641     if (*s=='M' || *s=='m') {
 642         if (n > (MAXPOSINT/1000000)) {
 643             ERRMSG(0) "Option setting \"%s\" is too large", t
 644             EEND;
 645         }
 646         n *= 1000000;
 647         s++;
 648     }
 649 #endif
 650
 651 #if MAXPOSINT > 1000000000
 652     if (*s=='G' || *s=='g') {
 653         if (n > (MAXPOSINT/1000000000)) {
 654             ERRMSG(0) "Option setting \"%s\" is too large", t
 655             EEND;
 656         }
 657         n *= 1000000000;
 658         s++;
 659     }
 660 #endif
 661
 662     if (*s!='\0') {
 663         ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
 664         EEND;
 665     }
 666
 667     return n;
 668 }
 669
 670 /* --------------------------------------------------------------------------
 671  * Print Menu of list of commands:
 672  * ------------------------------------------------------------------------*/
 673
 674 static struct cmd cmds[] = {
 675  {":?",      HELP},   {":cd",   CHGDIR},  {":also",    ALSO},
 676  {":type",   TYPEOF}, {":!",    SYSTEM},  {":load",    LOAD},
 677  {":reload", RELOAD}, {":gc",   COLLECT}, {":edit",    EDIT},
 678  {":quit",   QUIT},   {":set",  SET},     {":find",    FIND},
 679  {":names",  NAMES},  {":info", INFO},    {":project", PROJECT},
 680  {":dump",   DUMP},   {":ztats", STATS},
 681  {":module",SETMODULE},
 682  {":browse", BROWSE},
 683 #if EXPLAIN_INSTANCE_RESOLUTION
 684  {":xplain", XPLAIN},
 685 #endif
 686  {":version", PNTVER},
 687  {"",      EVAL},
 688  {0,0}
 689 };
 690
 691 static Void local menu() {
 692     Printf("LIST OF COMMANDS:  Any command may be abbreviated to :c where\n");
 693     Printf("c is the first character in the full name.\n\n");
 694     Printf(":load <filenames>   load modules from specified files\n");
 695     Printf(":load               clear all files except prelude\n");
 696     Printf(":also <filenames>   read additional modules\n");
 697     Printf(":reload             repeat last load command\n");
 698     Printf(":project <filename> use project file\n");
 699     Printf(":edit <filename>    edit file\n");
 700     Printf(":edit               edit last module\n");
 701     Printf(":module <module>    set module for evaluating expressions\n");
 702     Printf("<expr>              evaluate expression\n");
 703     Printf(":type <expr>        print type of expression\n");
 704     Printf(":?                  display this list of commands\n");
 705     Printf(":set <options>      set command line options\n");
 706     Printf(":set                help on command line options\n");
 707     Printf(":names [pat]        list names currently in scope\n");
 708     Printf(":info <names>       describe named objects\n");
 709     Printf(":browse <modules>   browse names defined in <modules>\n");
 710 #if EXPLAIN_INSTANCE_RESOLUTION
 711     Printf(":xplain <context>   explain instance resolution for <context>\n");
 712 #endif
 713     Printf(":find <name>        edit module containing definition of name\n");
 714     Printf(":!command           shell escape\n");
 715     Printf(":cd dir             change directory\n");
 716     Printf(":gc                 force garbage collection\n");
 717     Printf(":version            print Hugs version\n");
 718     Printf(":dump <name>        print STG code for named fn\n");
 719 #ifdef CRUDE_PROFILING
 720     Printf(":ztats <name>       print reduction stats\n");
 721 #endif
 722     Printf(":quit               exit Hugs interpreter\n");
 723 }
 724
 725 static Void local guidance() {
 726     Printf("Command not recognised.  ");
 727     forHelp();
 728 }
 729
 730 static Void local forHelp() {
 731     Printf("Type :? for help\n");
 732 }
 733
 734 /* --------------------------------------------------------------------------
 735  * Setting of command line options:
 736  * ------------------------------------------------------------------------*/
 737
 738 struct options toggle[] = {             /* List of command line toggles    */
 739     {'s', 1, "Print no. reductions/cells after eval", &showStats},
 740     {'t', 1, "Print type after evaluation",           &addType},
 741     {'g', 1, "Print no. cells recovered after gc",    &gcMessages},
 742     {'l', 1, "Literate modules as default",           &literateScripts},
 743     {'e', 1, "Warn about errors in literate modules", &literateErrors},
 744     {'.', 1, "Print dots to show progress",           &useDots},
 745     {'q', 1, "Print nothing to show progress",        &quiet},
 746     {'w', 1, "Always show which modules are loaded",  &listScripts},
 747     {'k', 1, "Show kind errors in full",              &kindExpert},
 748     {'o', 0, "Allow overlapping instances",           &allowOverlap},
 749
 750
 751 #if DEBUG_CODE
 752     {'D', 1, "Debug: show generated code",            &debugCode},
 753 #endif
 754 #if EXPLAIN_INSTANCE_RESOLUTION
 755     {'x', 1, "Explain instance resolution",           &showInstRes},
 756 #endif
 757 #if MULTI_INST
 758     {'m', 0, "Use multi instance resolution",         &multiInstRes},
 759 #endif
 760 #if DEBUG_CODE
 761     {'D', 1, "Debug: show generated G code",          &debugCode},
 762 #endif
 763 #if DEBUG_SHOWSC
 764     {'S', 1, "Debug: show generated SC code",         &debugSC},
 765 #endif
 766 #if 0
 767     {'f', 1, "Terminate evaluation on first error",   &failOnError},
 768     {'u', 1, "Use \"show\" to display results",       &useShow},
 769     {'i', 1, "Chase imports while loading modules",   &chaseImports},
 770 #endif
 771     {0,   0, 0,                                       0}
 772 };
 773
 774 static Void local set() {               /* change command line options from*/
 775     String s;                           /* Hugs command line               */
 776
 777     if ((s=readFilename())!=0) {
 778         do {
 779             if (!processOption(s)) {
 780                 ERRMSG(0) "Option string must begin with `+' or `-'"
 781                 EEND;
 782             }
 783         } while ((s=readFilename())!=0);
 784 #if USE_REGISTRY
 785         writeRegString("Options", optionsToStr());
 786 #endif
 787     }
 788     else
 789         optionInfo();
 790 }
 791
 792 /* --------------------------------------------------------------------------
 793  * Change directory command:
 794  * ------------------------------------------------------------------------*/
 795
 796 static Void local changeDir() {         /* change directory                */
 797     String s = readFilename();
 798     if (s && chdir(s)) {
 799         ERRMSG(0) "Unable to change to directory \"%s\"", s
 800         EEND;
 801     }
 802 }
 803
 804 /* --------------------------------------------------------------------------
 805  * Loading project and script files:
 806  * ------------------------------------------------------------------------*/
 807
 808 static Void local loadProject(s)        /* Load project file               */
 809 String s; {
 810     clearProject();
 811     currProject = s;
 812     projInput(currProject);
 813     scriptFile = currProject;
 814     forgetScriptsFrom(1);
 815     while ((s=readFilename())!=0)
 816         addStackEntry(s);
 817     if (namesUpto<=1) {
 818         ERRMSG(0) "Empty project file"
 819         EEND;
 820     }
 821     scriptFile    = 0;
 822     projectLoaded = TRUE;
 823 }
 824
 825 static Void local clearProject() {      /* clear name for current project  */
 826     if (currProject)
 827         free(currProject);
 828     currProject   = 0;
 829     projectLoaded = FALSE;
 830 #if HUGS_FOR_WINDOWS
 831     setLastEdit((String)0,0);
 832 #endif
 833 }
 834
 835
 836
 837 static Void local makeStackEntry ( ScriptInfo* ent, String iname )
 838 {
 839    Bool   ok, fromObj;
 840    Bool   sAvail, iAvail, oAvail;
 841    Time   sTime,  iTime,  oTime;
 842    Long   sSize,  iSize,  oSize;
 843    String path,   sExt;
 844
 845    ok = findFilesForModule (
 846            iname,
 847            &path,
 848            &sExt,
 849            &sAvail, &sTime, &sSize,
 850            &iAvail, &iTime, &iSize,
 851            &oAvail, &oTime, &oSize
 852         );
 853    if (!ok) {
 854       ERRMSG(0)
 855         /* "Can't file source or object+interface for module \"%s\"", */
 856          "Can't file source for module \"%s\"",
 857          iname
 858       EEND;
 859    }
 860    /* findFilesForModule should enforce this */
 861    if (!(sAvail || (oAvail && iAvail)))
 862       internal("chase");
 863    /* Load objects in preference to sources if both are available */
 864    /* 11 Oct 99: disable object loading in the interim.
 865       Will probably only reinstate when HEP becomes available.
 866    fromObj = sAvail
 867                 ? (oAvail && iAvail && timeEarlier(sTime,oTime))
 868                 : TRUE;
 869    */
 870    fromObj = FALSE;
 871
 872    /* ToDo: namesUpto overflow */
 873    ent->modName     = strCopy(iname);
 874    ent->details     = TRUE;
 875    ent->path        = path;
 876    ent->fromSource  = !fromObj;
 877    ent->srcExt      = sExt;
 878    ent->postponed   = FALSE;
 879    ent->lastChange  = sTime; /* ToDo: is this right? */
 880    ent->size        = fromObj ? iSize : sSize;
 881    ent->oSize       = fromObj ? oSize : 0;
 882    ent->objLoaded   = FALSE;
 883 }
 884
 885
 886
 887 static Void nukeEnding( String s )
 888 {
 889     Int l = strlen(s);
 890     if (l > 2 && strncmp(s+l-2,".o"  ,3)==0) s[l-2] = 0; else
 891     if (l > 3 && strncmp(s+l-3,".hi" ,3)==0) s[l-3] = 0; else
 892     if (l > 3 && strncmp(s+l-3,".hs" ,3)==0) s[l-3] = 0; else
 893     if (l > 4 && strncmp(s+l-4,".lhs",4)==0) s[l-4] = 0; else
 894     if (l > 4 && strncmp(s+l-4,".dll",4)==0) s[l-4] = 0; else
 895     if (l > 4 && strncmp(s+l-4,".DLL",4)==0) s[l-4] = 0;
 896 }
 897
 898 static Void local addStackEntry(s)     /* Add script to list of scripts    */
 899 String s; {                            /* to be read in ...                */
 900     String s2;
 901     Bool   found;
 902     Int    i;
 903
 904     if (namesUpto>=NUM_SCRIPTS) {
 905         ERRMSG(0) "Too many module files (maximum of %d allowed)",
 906                   NUM_SCRIPTS
 907         EEND;
 908     }
 909
 910     s = strCopy(s);
 911     nukeEnding(s);
 912     for (s2 = s; *s2; s2++)
 913        if (*s2 == SLASH && *(s2+1)) s = s2+1;
 914
 915     found = FALSE;
 916     for (i = 0; i < namesUpto; i++)
 917        if (strcmp(scriptInfo[i].modName,s)==0)
 918           found = TRUE;
 919
 920     if (!found) {
 921        makeStackEntry ( &scriptInfo[namesUpto], strCopy(s) );
 922        namesUpto++;
 923     }
 924     free(s);
 925 }
 926
 927 /* Return TRUE if no imports were needed; FALSE otherwise. */
 928 static Bool local addScript(stacknum)   /* read single file                */
 929 Int stacknum; {
 930    static char name[FILENAME_MAX+1];
 931    Int len = scriptInfo[stacknum].size;
 932
 933 #if HUGS_FOR_WINDOWS                    /* Set clock cursor while loading  */
 934     allowBreak();
 935     SetCursor(LoadCursor(NULL, IDC_WAIT));
 936 #endif
 937
 938     //   setLastEdit(name,0);
 939
 940    nameObj[0] = 0;
 941    strcpy(name, scriptInfo[stacknum].path);
 942    strcat(name, scriptInfo[stacknum].modName);
 943    if (scriptInfo[stacknum].fromSource)
 944       strcat(name, scriptInfo[stacknum].srcExt); else
 945       strcat(name, ".hi");
 946
 947    scriptFile = name;
 948
 949    if (scriptInfo[stacknum].fromSource) {
 950       if (lastWasObject) finishInterfaces();
 951       lastWasObject = FALSE;
 952       Printf("Reading script \"%s\":\n",name);
 953       needsImports = FALSE;
 954       parseScript(name,len);
 955       if (needsImports) return FALSE;
 956       checkDefns();
 957       typeCheckDefns();
 958       compileDefns();
 959    } else {
 960       Printf("Reading  iface \"%s\":\n", name);
 961       scriptFile = name;
 962       needsImports = FALSE;
 963
 964       // set nameObj for the benefit of openGHCIface
 965       strcpy(nameObj, scriptInfo[stacknum].path);
 966       strcat(nameObj, scriptInfo[stacknum].modName);
 967       strcat(nameObj, DLL_ENDING);
 968       sizeObj = scriptInfo[stacknum].oSize;
 969
 970       loadInterface(name,len);
 971       scriptFile = 0;
 972       lastWasObject = TRUE;
 973       if (needsImports) return FALSE;
 974    }
 975
 976    scriptFile = 0;
 977    preludeLoaded = TRUE;
 978    return TRUE;
 979 }
 980
 981
 982 Bool chase(imps)                        /* Process list of import requests */
 983 List imps; {
 984     Int    dstPosn;
 985     ScriptInfo tmp;
 986     Int    origPos  = numScripts;       /* keep track of original position */
 987     String origName = scriptInfo[origPos].modName;
 988     for (; nonNull(imps); imps=tl(imps)) {
 989         String iname = textToStr(textOf(hd(imps)));
 990         Int    i     = 0;
 991         for (; i<namesUpto; i++)
 992             if (strcmp(scriptInfo[i].modName,iname)==0)
 993                 break;
 994         //fprintf(stderr, "import name = %s   num = %d\n", iname, i );
 995
 996         if (i<namesUpto) {
 997            /* We should have filled in the details of each module
 998               the first time we hear about it.
 999            */
1000            assert(scriptInfo[i].details);
1001         }
1002
1003         if (i>=origPos) {               /* Neither loaded or queued        */
1004             String theName;
1005             Time   theTime;
1006             Bool   thePost;
1007             Bool   theFS;
1008
1009             needsImports = TRUE;
1010             if (scriptInfo[origPos].fromSource)
1011                scriptInfo[origPos].postponed  = TRUE;
1012
1013             if (i==namesUpto) {         /* Name not found (i==namesUpto)   */
1014                  /* Find out where it lives, whether source or object, etc */
1015                makeStackEntry ( &scriptInfo[i], iname );
1016                namesUpto++;
1017             }
1018             else
1019             if (scriptInfo[i].postponed && scriptInfo[i].fromSource) {
1020                                         /* Check for recursive dependency  */
1021                 ERRMSG(0)
1022                   "Recursive import dependency between \"%s\" and \"%s\"",
1023                   scriptInfo[origPos].modName, iname
1024                 EEND;
1025             }
1026             /* Move stack entry i to somewhere below origPos.  If i denotes
1027              * an object, destination is immediately below origPos.
1028              * Otherwise, it's underneath the queue of objects below origPos.
1029              */
1030             dstPosn = origPos-1;
1031             if (scriptInfo[i].fromSource)
1032                while (!scriptInfo[dstPosn].fromSource && dstPosn > 0)
1033                   dstPosn--;
1034
1035             dstPosn++;
1036             tmp = scriptInfo[i];
1037             for (; i > dstPosn; i--) scriptInfo[i] = scriptInfo[i-1];
1038             scriptInfo[dstPosn] = tmp;
1039             if (dstPosn < nextNumScripts) nextNumScripts = dstPosn;
1040             origPos++;
1041         }
1042     }
1043     return needsImports;
1044 }
1045
1046 static Void local forgetScriptsFrom(scno)/* remove scripts from system     */
1047 Script scno; {
1048     Script i;
1049 #if 0
1050     for (i=scno; i<namesUpto; ++i)
1051         if (scriptName[i])
1052             free(scriptName[i]);
1053 #endif
1054     dropScriptsFrom(scno-1);
1055     namesUpto = scno;
1056     if (numScripts>namesUpto)
1057         numScripts = scno;
1058 }
1059
1060 /* --------------------------------------------------------------------------
1061  * Commands for loading and removing script files:
1062  * ------------------------------------------------------------------------*/
1063
1064 static Void local load() {           /* read filenames from command line   */
1065     String s;                        /* and add to list of scripts waiting */
1066                                      /* to be read                         */
1067     while ((s=readFilename())!=0)
1068         addStackEntry(s);
1069     readScripts(1);
1070 }
1071
1072 static Void local project() {          /* read list of script names from   */
1073     String s;                          /* project file                     */
1074
1075     if ((s=readFilename()) || currProject) {
1076         if (!s)
1077             s = strCopy(currProject);
1078         else if (readFilename()) {
1079             ERRMSG(0) "Too many project files"
1080             EEND;
1081         }
1082         else
1083             s = strCopy(s);
1084     }
1085     else {
1086         ERRMSG(0) "No project filename specified"
1087         EEND;
1088     }
1089     loadProject(s);
1090     readScripts(1);
1091 }
1092
1093 static Void local readScripts(n)        /* Reread current list of scripts, */
1094 Int n; {                                /* loading everything after and    */
1095     Time timeStamp;                     /* including the first script which*/
1096     Long fileSize;                      /* has been either changed or added*/
1097     static char name[FILENAME_MAX+1];
1098
1099     lastWasObject = FALSE;
1100     ppSmStack("readscripts-begin");
1101 #if HUGS_FOR_WINDOWS
1102     SetCursor(LoadCursor(NULL, IDC_WAIT));
1103 #endif
1104
1105 #if 0
1106     for (; n<numScripts; n++) {         /* Scan previously loaded scripts  */
1107         ppSmStack("readscripts-loop1");
1108         getFileInfo(scriptName[n], &timeStamp, &fileSize);
1109         if (timeChanged(timeStamp,lastChange[n])) {
1110             dropScriptsFrom(n-1);
1111             numScripts = n;
1112             break;
1113         }
1114     }
1115     for (; n<NUM_SCRIPTS; n++)          /* No scripts have been postponed  */
1116         postponed[n] = FALSE;           /* at this stage                   */
1117     numScripts = 0;
1118
1119     while (numScripts<namesUpto) {      /* Process any remaining scripts   */
1120         ppSmStack("readscripts-loop2");
1121         getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
1122         timeSet(lastChange[numScripts],timeStamp);
1123         if (numScripts>0)               /* no new script for prelude       */
1124             startNewScript(scriptName[numScripts]);
1125         if (addScript(scriptName[numScripts],fileSize))
1126             numScripts++;
1127         else
1128             dropScriptsFrom(numScripts-1);
1129     }
1130 #endif
1131
1132     interface(RESET);
1133
1134     for (; n<numScripts; n++) {
1135         ppSmStack("readscripts-loop2");
1136         strcpy(name, scriptInfo[n].path);
1137         strcat(name, scriptInfo[n].modName);
1138         if (scriptInfo[n].fromSource)
1139            strcat(name, scriptInfo[n].srcExt); else
1140            strcat(name, ".hi");  //ToDo: should be .o
1141         getFileInfo(name,&timeStamp, &fileSize);
1142         if (timeChanged(timeStamp,scriptInfo[n].lastChange)) {
1143            dropScriptsFrom(n-1);
1144            numScripts = n;
1145            break;
1146         }
1147     }
1148     for (; n<NUM_SCRIPTS; n++)
1149         scriptInfo[n].postponed = FALSE;
1150
1151     //numScripts = 0;
1152
1153     while (numScripts < namesUpto) {
1154 ppSmStack ( "readscripts-loop2" );
1155
1156        if (scriptInfo[numScripts].fromSource) {
1157
1158           if (numScripts>0)
1159               startNewScript(scriptInfo[numScripts].modName);
1160           nextNumScripts = NUM_SCRIPTS; //bogus initialisation
1161           if (addScript(numScripts)) {
1162              numScripts++;
1163 assert(nextNumScripts==NUM_SCRIPTS);
1164           }
1165           else
1166              dropScriptsFrom(numScripts-1);
1167
1168        } else {
1169
1170           if (scriptInfo[numScripts].objLoaded) {
1171              numScripts++;
1172           } else {
1173              scriptInfo[numScripts].objLoaded = TRUE;
1174              /* new */
1175              if (numScripts>0)
1176                  startNewScript(scriptInfo[numScripts].modName);
1177              /* end */
1178              nextNumScripts = NUM_SCRIPTS;
1179              if (addScript(numScripts)) {
1180                 numScripts++;
1181 assert(nextNumScripts==NUM_SCRIPTS);
1182              } else {
1183                 //while (!scriptInfo[numScripts].fromSource && numScripts > 0)
1184                 //   numScripts--;
1185                 //if (scriptInfo[numScripts].fromSource)
1186                 //   numScripts++;
1187                 numScripts = nextNumScripts;
1188 assert(nextNumScripts<NUM_SCRIPTS);
1189              }
1190           }
1191        }
1192 if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
1193     }
1194
1195     finishInterfaces();
1196
1197     { Int  m     = namesUpto-1;
1198       Text mtext = findText(scriptInfo[m].modName);
1199       /* Commented out till we understand what
1200        * this is trying to do.
1201        * Problem, you cant find a module till later.
1202        */
1203 #if 0
1204        setCurrModule(findModule(mtext));
1205 #endif
1206       evalModule = mtext;
1207     }
1208
1209
1210
1211     if (listScripts)
1212         whatScripts();
1213     if (numScripts<=1)
1214         setLastEdit((String)0, 0);
1215     ppSmStack("readscripts-end  ");
1216 }
1217
1218 static Void local whatScripts() {       /* list scripts in current session */
1219     int i;
1220     Printf("\nHugs session for:");
1221     if (projectLoaded)
1222         Printf(" (project: %s)",currProject);
1223     for (i=0; i<numScripts; ++i)
1224       Printf("\n%s%s",scriptInfo[i].path, scriptInfo[i].modName);
1225     Putchar('\n');
1226 }
1227
1228 /* --------------------------------------------------------------------------
1229  * Access to external editor:
1230  * ------------------------------------------------------------------------*/
1231
1232 static Void local editor() {            /* interpreter-editor interface    */
1233     String newFile  = readFilename();
1234     if (newFile) {
1235         setLastEdit(newFile,0);
1236         if (readFilename()) {
1237             ERRMSG(0) "Multiple filenames not permitted"
1238             EEND;
1239         }
1240     }
1241     runEditor();
1242 }
1243
1244 static Void local find() {              /* edit file containing definition */
1245 #if 0
1246 This just plain wont work no more.
1247 ToDo: Fix!
1248     String nm = readFilename();         /* of specified name               */
1249     if (!nm) {
1250         ERRMSG(0) "No name specified"
1251         EEND;
1252     }
1253     else if (readFilename()) {
1254         ERRMSG(0) "Multiple names not permitted"
1255         EEND;
1256     }
1257     else {
1258         Text t;
1259         Cell c;
1260         setCurrModule(findEvalModule());
1261         startNewScript(0);
1262         if (nonNull(c=findTycon(t=findText(nm)))) {
1263             if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
1264                 readScripts(1);
1265             }
1266         } else if (nonNull(c=findName(t))) {
1267             if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
1268                 readScripts(1);
1269             }
1270         } else {
1271             ERRMSG(0) "No current definition for name \"%s\"", nm
1272             EEND;
1273         }
1274     }
1275 #endif
1276 }
1277
1278 static Void local runEditor() {         /* run editor on script lastEdit   */
1279     if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine              */
1280         readScripts(1);
1281 }
1282
1283 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
1284 String fname;
1285 Int    line; {
1286     if (lastEdit)
1287         free(lastEdit);
1288     lastEdit = strCopy(fname);
1289     lastEdLine = line;
1290 #if HUGS_FOR_WINDOWS
1291     DrawStatusLine(hWndMain);           /* Redo status line                */
1292 #endif
1293 }
1294
1295 /* --------------------------------------------------------------------------
1296  * Read and evaluate an expression:
1297  * ------------------------------------------------------------------------*/
1298
1299 static Void local setModule(){/*set module in which to evaluate expressions*/
1300     String s = readFilename();
1301     if (!s) s = "";              /* :m clears the current module selection */
1302     evalModule = findText(s);
1303     setLastEdit(fileOfModule(findEvalModule()),0);
1304 }
1305
1306 static Module local findEvalModule() { /*Module in which to eval expressions*/
1307     Module m = findModule(evalModule);
1308     if (isNull(m))
1309         m = lastModule();
1310     return m;
1311 }
1312
1313 static Void local evaluator() {        /* evaluate expr and print value    */
1314     Type  type, bd;
1315     Kinds ks   = NIL;
1316
1317     setCurrModule(findEvalModule());
1318     scriptFile = 0;
1319     startNewScript(0);                 /* Enables recovery of storage      */
1320                                        /* allocated during evaluation      */
1321     parseExp();
1322     checkExp();
1323     defaultDefns = evalDefaults;
1324     type         = typeCheckExp(TRUE);
1325     if (isPolyType(type)) {
1326         ks = polySigOf(type);
1327         bd = monotypeOf(type);
1328     }
1329     else
1330         bd = type;
1331
1332     if (whatIs(bd)==QUAL) {
1333         ERRMSG(0) "Unresolved overloading" ETHEN
1334         ERRTEXT   "\n*** Type       : "    ETHEN ERRTYPE(type);
1335         ERRTEXT   "\n*** Expression : "    ETHEN ERREXPR(inputExpr);
1336         ERRTEXT   "\n"
1337         EEND;
1338     }
1339
1340 #ifdef WANT_TIMER
1341     updateTimers();
1342 #endif
1343
1344 #if 1
1345     if (typeMatches(type,ap(typeIO,typeUnit))) {
1346         inputExpr = ap(nameRunIO,inputExpr);
1347         evalExp();
1348         Putchar('\n');
1349     } else {
1350         Cell d = provePred(ks,NIL,ap(classShow,bd));
1351         if (isNull(d)) {
1352             ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1353             ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
1354             ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
1355             ERRTEXT   "\n"
1356             EEND;
1357         }
1358         inputExpr = ap2(findName(findText("show")),d,inputExpr);
1359         inputExpr = ap(findName(findText("putStr")), inputExpr);
1360         inputExpr = ap(nameRunIO, inputExpr);
1361
1362         evalExp(); printf("\n");
1363         if (addType) {
1364             printf(" :: ");
1365             printType(stdout,type);
1366             Putchar('\n');
1367         }
1368     }
1369
1370 #else
1371
1372    printf ( "result type is " );
1373    printType ( stdout, type );
1374    printf ( "\n" );
1375    evalExp();
1376    printf ( "\n" );
1377
1378 #endif
1379
1380 }
1381
1382 static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
1383     if (printing) {                    /* after successful termination or  */
1384         printing = FALSE;              /* runtime error (e.g. interrupt)   */
1385         Putchar('\n');
1386         if (showStats) {
1387 #define plural(v)   v, (v==1?"":"s")
1388             Printf("%lu cell%s",plural(numCells));
1389             if (numGcs>0)
1390                 Printf(", %u garbage collection%s",plural(numGcs));
1391             Printf(")\n");
1392 #undef plural
1393         }
1394         FlushStdout();
1395         garbageCollect();
1396     }
1397 }
1398
1399 /* --------------------------------------------------------------------------
1400  * Print type of input expression:
1401  * ------------------------------------------------------------------------*/
1402
1403 static Void local showtype() {         /* print type of expression (if any)*/
1404     Cell type;
1405
1406     setCurrModule(findEvalModule());
1407     startNewScript(0);                 /* Enables recovery of storage      */
1408                                        /* allocated during evaluation      */
1409     parseExp();
1410     checkExp();
1411     defaultDefns = evalDefaults;
1412     type = typeCheckExp(FALSE);
1413     printExp(stdout,inputExpr);
1414     Printf(" :: ");
1415     printType(stdout,type);
1416     Putchar('\n');
1417 }
1418
1419
1420 static Void local browseit(mod,t,all)
1421 Module mod;
1422 String t;
1423 Bool all; {
1424     if (nonNull(mod)) {
1425         Cell cs;
1426         if (nonNull(t))
1427             Printf("module %s where\n",textToStr(module(mod).text));
1428         for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
1429             Name nm = hd(cs);
1430             /* only look at things defined in this module,
1431                unless `all' flag is set */
1432             if (all || name(nm).mod == mod) {
1433                 /* unwanted artifacts, like lambda lifted values,
1434                    are in the list of names, but have no types */
1435                 if (nonNull(name(nm).type)) {
1436                     printExp(stdout,nm);
1437                     Printf(" :: ");
1438                     printType(stdout,name(nm).type);
1439                     if (isCfun(nm)) {
1440                         Printf("  -- data constructor");
1441                     } else if (isMfun(nm)) {
1442                         Printf("  -- class member");
1443                     } else if (isSfun(nm)) {
1444                         Printf("  -- selector function");
1445                     }
1446                     Printf("\n");
1447                 }
1448             }
1449         }
1450     } else {
1451       if (isNull(mod)) {
1452         Printf("Unknown module %s\n",t);
1453       }
1454     }
1455 }
1456
1457 static Void local browse() {            /* browse modules                  */
1458     Int    count = 0;                   /* or give menu of commands        */
1459     String s;
1460     Bool all = FALSE;
1461
1462     setCurrModule(findEvalModule());
1463     startNewScript(0);                  /* for recovery of storage         */
1464     for (; (s=readFilename())!=0; count++)
1465         if (strcmp(s,"all") == 0) {
1466             all = TRUE;
1467             --count;
1468         } else
1469             browseit(findModule(findText(s)),s,all);
1470     if (count == 0) {
1471         browseit(findEvalModule(),NULL,all);
1472     }
1473 }
1474
1475 #if EXPLAIN_INSTANCE_RESOLUTION
1476 static Void local xplain() {         /* print type of expression (if any)*/
1477     Cell d;
1478     Bool sir = showInstRes;
1479
1480     setCurrModule(findEvalModule());
1481     startNewScript(0);                 /* Enables recovery of storage      */
1482                                        /* allocated during evaluation      */
1483     parseContext();
1484     checkContext();
1485     showInstRes = TRUE;
1486     d = provePred(NIL,NIL,hd(inputContext));
1487     if (isNull(d)) {
1488         fprintf(stdout, "not Sat\n");
1489     } else {
1490         fprintf(stdout, "Sat\n");
1491     }
1492     showInstRes = sir;
1493 }
1494 #endif
1495
1496 /* --------------------------------------------------------------------------
1497  * Enhanced help system:  print current list of scripts or give information
1498  * about an object.
1499  * ------------------------------------------------------------------------*/
1500
1501 static String local objToStr(m,c)
1502 Module m;
1503 Cell   c; {
1504 #if 1 || DISPLAY_QUANTIFIERS
1505     static char newVar[60];
1506     switch (whatIs(c)) {
1507         case NAME  : if (m == name(c).mod) {
1508                          sprintf(newVar,"%s", textToStr(name(c).text));
1509                      } else {
1510                          sprintf(newVar,"%s.%s",
1511                                         textToStr(module(name(c).mod).text),
1512                                         textToStr(name(c).text));
1513                      }
1514                      break;
1515
1516         case TYCON : if (m == tycon(c).mod) {
1517                          sprintf(newVar,"%s", textToStr(tycon(c).text));
1518                      } else {
1519                          sprintf(newVar,"%s.%s",
1520                                         textToStr(module(tycon(c).mod).text),
1521                                         textToStr(tycon(c).text));
1522                      }
1523                      break;
1524
1525         case CLASS : if (m == cclass(c).mod) {
1526                          sprintf(newVar,"%s", textToStr(cclass(c).text));
1527                      } else {
1528                          sprintf(newVar,"%s.%s",
1529                                         textToStr(module(cclass(c).mod).text),
1530                                         textToStr(cclass(c).text));
1531                      }
1532                      break;
1533
1534         default    : internal("objToStr");
1535     }
1536     return newVar;
1537 #else
1538     static char newVar[33];
1539     switch (whatIs(c)) {
1540         case NAME  : sprintf(newVar,"%s", textToStr(name(c).text));
1541                      break;
1542
1543         case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1544                      break;
1545
1546         case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1547                      break;
1548
1549         default    : internal("objToStr");
1550     }
1551     return newVar;
1552 #endif
1553 }
1554
1555 extern Name nameHw;
1556
1557 static Void local dumpStg( void ) {       /* print STG stuff                 */
1558     String s;
1559     Text   t;
1560     Name   n;
1561     Int    i;
1562     Cell   v;                           /* really StgVar */
1563     setCurrModule(findEvalModule());
1564     startNewScript(0);
1565     for (; (s=readFilename())!=0;) {
1566         t = findText(s);
1567         v = n = NIL;
1568         /* find the name while ignoring module scopes */
1569         for (i=NAMEMIN; i<nameHw; i++)
1570            if (name(i).text == t) n = i;
1571
1572         /* perhaps it's an "idNNNNNN" thing? */
1573         if (isNull(n) &&
1574             strlen(s) >= 3 &&
1575             s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
1576            v = 0;
1577            i = 2;
1578            while (isdigit(s[i])) {
1579               v = v * 10 + (s[i]-'0');
1580               i++;
1581            }
1582            v = -v;
1583            n = nameFromStgVar(v);
1584         }
1585
1586         if (isNull(n) && whatIs(v)==STGVAR) {
1587            Printf ( "\n{- `%s' has no nametable entry -}\n", s );
1588            printStg(stderr, v );
1589         } else
1590         if (isNull(n)) {
1591            Printf ( "Unknown reference `%s'\n", s );
1592         } else
1593         if (!isName(n)) {
1594            Printf ( "Not a Name: `%s'\n", s );
1595         } else
1596         if (isNull(name(n).stgVar)) {
1597            Printf ( "Doesn't have a STG tree: %s\n", s );
1598         } else {
1599            Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
1600            printStg(stderr, name(n).stgVar);
1601         }
1602     }
1603 }
1604
1605 static Void local info() {              /* describe objects                */
1606     Int    count = 0;                   /* or give menu of commands        */
1607     String s;
1608
1609     setCurrModule(findEvalModule());
1610     startNewScript(0);                  /* for recovery of storage         */
1611     for (; (s=readFilename())!=0; count++) {
1612         describe(findText(s));
1613     }
1614     if (count == 0) {
1615         whatScripts();
1616     }
1617 }
1618
1619
1620 static Void local describe(t)           /* describe an object              */
1621 Text t; {
1622     Tycon  tc  = findTycon(t);
1623     Class  cl  = findClass(t);
1624     Name   nm  = findName(t);
1625
1626     if (nonNull(tc)) {                  /* as a type constructor           */
1627         Type t = tc;
1628         Int  i;
1629         Inst in;
1630         for (i=0; i<tycon(tc).arity; ++i) {
1631             t = ap(t,mkOffset(i));
1632         }
1633         Printf("-- type constructor");
1634         if (kindExpert) {
1635             Printf(" with kind ");
1636             printKind(stdout,tycon(tc).kind);
1637         }
1638         Putchar('\n');
1639         switch (tycon(tc).what) {
1640             case SYNONYM      : Printf("type ");
1641                                 printType(stdout,t);
1642                                 Printf(" = ");
1643                                 printType(stdout,tycon(tc).defn);
1644                                 break;
1645
1646             case NEWTYPE      :
1647             case DATATYPE     : {   List cs = tycon(tc).defn;
1648                                     if (tycon(tc).what==DATATYPE) {
1649                                         Printf("data ");
1650                                     } else {
1651                                         Printf("newtype ");
1652                                     }
1653                                     printType(stdout,t);
1654                                     Putchar('\n');
1655                                     mapProc(printSyntax,cs);
1656                                     if (hasCfun(cs)) {
1657                                         Printf("\n-- constructors:");
1658                                     }
1659                                     for (; hasCfun(cs); cs=tl(cs)) {
1660                                         Putchar('\n');
1661                                         printExp(stdout,hd(cs));
1662                                         Printf(" :: ");
1663                                         printType(stdout,name(hd(cs)).type);
1664                                     }
1665                                     if (nonNull(cs)) {
1666                                         Printf("\n-- selectors:");
1667                                     }
1668                                     for (; nonNull(cs); cs=tl(cs)) {
1669                                         Putchar('\n');
1670                                         printExp(stdout,hd(cs));
1671                                         Printf(" :: ");
1672                                         printType(stdout,name(hd(cs)).type);
1673                                     }
1674                                 }
1675                                 break;
1676
1677             case RESTRICTSYN  : Printf("type ");
1678                                 printType(stdout,t);
1679                                 Printf(" = <restricted>");
1680                                 break;
1681         }
1682         Putchar('\n');
1683         if (nonNull(in=findFirstInst(tc))) {
1684             Printf("\n-- instances:\n");
1685             do {
1686                 showInst(in);
1687                 in = findNextInst(tc,in);
1688             } while (nonNull(in));
1689         }
1690         Putchar('\n');
1691     }
1692
1693     if (nonNull(cl)) {                  /* as a class                      */
1694         List  ins = cclass(cl).instances;
1695         Kinds ks  = cclass(cl).kinds;
1696         if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1697             Printf("-- type class");
1698         } else {
1699             Printf("-- constructor class");
1700             if (kindExpert) {
1701                 Printf(" with arity ");
1702                 printKinds(stdout,ks);
1703             }
1704         }
1705         Putchar('\n');
1706         mapProc(printSyntax,cclass(cl).members);
1707         Printf("class ");
1708         if (nonNull(cclass(cl).supers)) {
1709             printContext(stdout,cclass(cl).supers);
1710             Printf(" => ");
1711         }
1712         printPred(stdout,cclass(cl).head);
1713
1714         if (nonNull(cclass(cl).fds)) {
1715             List   fds = cclass(cl).fds;
1716             String pre = " | ";
1717             for (; nonNull(fds); fds=tl(fds)) {
1718                 Printf(pre);
1719                 printFD(stdout,hd(fds));
1720                 pre = ", ";
1721             }
1722         }
1723
1724         if (nonNull(cclass(cl).members)) {
1725             List ms = cclass(cl).members;
1726             Printf(" where");
1727             do {
1728                 Type t = name(hd(ms)).type;
1729                 if (isPolyType(t)) {
1730                     t = monotypeOf(t);
1731                 }
1732                 Printf("\n  ");
1733                 printExp(stdout,hd(ms));
1734                 Printf(" :: ");
1735                 if (isNull(tl(fst(snd(t))))) {
1736                     t = snd(snd(t));
1737                 } else {
1738                     t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1739                 }
1740                 printType(stdout,t);
1741                 ms = tl(ms);
1742             } while (nonNull(ms));
1743         }
1744         Putchar('\n');
1745         if (nonNull(ins)) {
1746             Printf("\n-- instances:\n");
1747             do {
1748                 showInst(hd(ins));
1749                 ins = tl(ins);
1750             } while (nonNull(ins));
1751         }
1752         Putchar('\n');
1753     }
1754
1755     if (nonNull(nm)) {                  /* as a function/name              */
1756         printSyntax(nm);
1757         printExp(stdout,nm);
1758         Printf(" :: ");
1759         if (nonNull(name(nm).type)) {
1760             printType(stdout,name(nm).type);
1761         } else {
1762             Printf("<unknown type>");
1763         }
1764
1765         if (isCfun(nm)) {
1766             Printf("  -- data constructor");
1767         } else if (isMfun(nm)) {
1768             Printf("  -- class member");
1769         } else if (isSfun(nm)) {
1770             Printf("  -- selector function");
1771         }
1772         Printf("\n\n");
1773     }
1774
1775
1776     if (isNull(tc) && isNull(cl) && isNull(nm)) {
1777         Printf("Unknown reference `%s'\n",textToStr(t));
1778     }
1779 }
1780
1781 static Void local printSyntax(nm)
1782 Name nm; {
1783     Syntax sy = syntaxOf(nm);
1784     Text   t  = name(nm).text;
1785     String s  = textToStr(t);
1786     if (sy != defaultSyntax(t)) {
1787         Printf("infix");
1788         switch (assocOf(sy)) {
1789             case LEFT_ASS  : Putchar('l'); break;
1790             case RIGHT_ASS : Putchar('r'); break;
1791             case NON_ASS   : break;
1792         }
1793         Printf(" %i ",precOf(sy));
1794         if (isascii((int)(*s)) && isalpha((int)(*s))) {
1795             Printf("`%s`",s);
1796         } else {
1797             Printf("%s",s);
1798         }
1799         Putchar('\n');
1800     }
1801 }
1802
1803 static Void local showInst(in)          /* Display instance decl header    */
1804 Inst in; {
1805     Printf("instance ");
1806     if (nonNull(inst(in).specifics)) {
1807         printContext(stdout,inst(in).specifics);
1808         Printf(" => ");
1809     }
1810     printPred(stdout,inst(in).head);
1811     Putchar('\n');
1812 }
1813
1814 /* --------------------------------------------------------------------------
1815  * List all names currently in scope:
1816  * ------------------------------------------------------------------------*/
1817
1818 static Void local listNames() {         /* list names matching optional pat*/
1819     String pat   = readFilename();
1820     List   names = NIL;
1821     Int    width = getTerminalWidth() - 1;
1822     Int    count = 0;
1823     Int    termPos;
1824     Module mod   = findEvalModule();
1825
1826     if (pat) {                          /* First gather names to list      */
1827         do {
1828             names = addNamesMatching(pat,names);
1829         } while ((pat=readFilename())!=0);
1830     } else {
1831         names = addNamesMatching((String)0,names);
1832     }
1833     if (isNull(names)) {                /* Then print them out             */
1834         ERRMSG(0) "No names selected"
1835         EEND;
1836     }
1837     for (termPos=0; nonNull(names); names=tl(names)) {
1838         String s = objToStr(mod,hd(names));
1839         Int    l = strlen(s);
1840         if (termPos+1+l>width) {
1841             Putchar('\n');
1842             termPos = 0;
1843         } else if (termPos>0) {
1844             Putchar(' ');
1845             termPos++;
1846         }
1847         Printf("%s",s);
1848         termPos += l;
1849         count++;
1850     }
1851     Printf("\n(%d names listed)\n", count);
1852 }
1853
1854 /* --------------------------------------------------------------------------
1855  * print a prompt and read a line of input:
1856  * ------------------------------------------------------------------------*/
1857
1858 static Void local promptForInput(moduleName)
1859 String moduleName; {
1860     char promptBuffer[1000];
1861 #if 1
1862     /* This is portable but could overflow buffer */
1863     sprintf(promptBuffer,prompt,moduleName);
1864 #else
1865     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1866      * promptBuffer instead.
1867      */
1868     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1869         /* Reset prompt to a safe default to avoid an infinite loop */
1870         free(prompt);
1871         prompt = strCopy("? ");
1872         internal("Combined prompt and evaluation module name too long");
1873     }
1874 #endif
1875     if (autoMain)
1876        stringInput("main\0"); else
1877        consoleInput(promptBuffer);
1878 }
1879
1880 /* --------------------------------------------------------------------------
1881  * main read-eval-print loop, with error trapping:
1882  * ------------------------------------------------------------------------*/
1883
1884 static jmp_buf catch_error;             /* jump buffer for error trapping  */
1885
1886 static Void local interpreter(argc,argv)/* main interpreter loop           */
1887 Int    argc;
1888 String argv[]; {
1889     Int errorNumber = setjmp(catch_error);
1890
1891     if (errorNumber && autoMain) {
1892        fprintf(stderr, "hugs +Q: compilation failed -- can't run `main'\n" );
1893        exit(1);
1894     }
1895
1896     breakOn(TRUE);                      /* enable break trapping           */
1897     if (numScripts==0) {                /* only succeeds on first time,    */
1898         if (errorNumber)                /* before prelude has been loaded  */
1899             fatal("Unable to load prelude");
1900         initialize(argc,argv);
1901         forHelp();
1902     }
1903
1904     /* initialize calls startupHaskell, which trashes our signal handlers */
1905     breakOn(TRUE);
1906
1907     for (;;) {
1908         Command cmd;
1909         everybody(RESET);               /* reset to sensible initial state */
1910         dropScriptsFrom(numScripts-1);  /* remove partially loaded scripts */
1911                                         /* not counting prelude as a script*/
1912
1913         promptForInput(textToStr(module(findEvalModule()).text));
1914
1915         cmd = readCommand(cmds, (Char)':', (Char)'!');
1916 #ifdef WANT_TIMER
1917         updateTimers();
1918 #endif
1919         switch (cmd) {
1920             case EDIT   : editor();
1921                           break;
1922             case FIND   : find();
1923                           break;
1924             case LOAD   : clearProject();
1925                           forgetScriptsFrom(1);
1926                           load();
1927                           break;
1928             case ALSO   : clearProject();
1929                           forgetScriptsFrom(numScripts);
1930                           load();
1931                           break;
1932             case RELOAD : readScripts(1);
1933                           break;
1934             case PROJECT: project();
1935                           break;
1936             case SETMODULE :
1937                           setModule();
1938                           break;
1939             case EVAL   : evaluator();
1940                           break;
1941             case TYPEOF : showtype();
1942                           break;
1943             case BROWSE : browse();
1944                           break;
1945 #if EXPLAIN_INSTANCE_RESOLUTION
1946             case XPLAIN : xplain();
1947                           break;
1948 #endif
1949             case NAMES  : listNames();
1950                           break;
1951             case HELP   : menu();
1952                           break;
1953             case BADCMD : guidance();
1954                           break;
1955             case SET    : set();
1956                           break;
1957             case STATS:
1958 #ifdef CRUDE_PROFILING
1959                           cp_show();
1960 #endif
1961                           break;
1962             case SYSTEM : if (shellEsc(readLine()))
1963                               Printf("Warning: Shell escape terminated abnormally\n");
1964                           break;
1965             case CHGDIR : changeDir();
1966                           break;
1967             case INFO   : info();
1968                           break;
1969             case PNTVER: Printf("-- Hugs Version %s\n",
1970                                  HUGS_VERSION);
1971                           break;
1972             case DUMP   : dumpStg();
1973                           break;
1974             case QUIT   : return;
1975             case COLLECT: consGC = FALSE;
1976                           garbageCollect();
1977                           consGC = TRUE;
1978                           Printf("Garbage collection recovered %d cells\n",
1979                                  cellsRecovered);
1980                           break;
1981             case NOCMD  : break;
1982         }
1983 #ifdef WANT_TIMER
1984         updateTimers();
1985         Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
1986                millisecs(userElapsed), millisecs(systElapsed));
1987 #endif
1988         if (autoMain) break;
1989     }
1990     breakOn(FALSE);
1991 }
1992
1993 /* --------------------------------------------------------------------------
1994  * Display progress towards goal:
1995  * ------------------------------------------------------------------------*/
1996
1997 static Target currTarget;
1998 static Bool   aiming = FALSE;
1999 static Int    currPos;
2000 static Int    maxPos;
2001 static Int    charCount;
2002
2003 Void setGoal(what, t)                  /* Set goal for what to be t        */
2004 String what;
2005 Target t; {
2006     if (quiet)
2007       return;
2008 #if EXPLAIN_INSTANCE_RESOLUTION
2009     if (showInstRes)
2010       return;
2011 #endif
2012     currTarget = (t?t:1);
2013     aiming     = TRUE;
2014     if (useDots) {
2015         currPos = strlen(what);
2016         maxPos  = getTerminalWidth() - 1;
2017         Printf("%s",what);
2018     }
2019     else
2020         for (charCount=0; *what; charCount++)
2021             Putchar(*what++);
2022     FlushStdout();
2023 }
2024
2025 Void soFar(t)                          /* Indicate progress towards goal   */
2026 Target t; {                            /* has now reached t                */
2027     if (quiet)
2028       return;
2029 #if EXPLAIN_INSTANCE_RESOLUTION
2030     if (showInstRes)
2031       return;
2032 #endif
2033     if (useDots) {
2034         Int newPos = (Int)((maxPos * ((long)t))/currTarget);
2035
2036         if (newPos>maxPos)
2037             newPos = maxPos;
2038
2039         if (newPos>currPos) {
2040             do
2041                 Putchar('.');
2042             while (newPos>++currPos);
2043             FlushStdout();
2044         }
2045         FlushStdout();
2046     }
2047 }
2048
2049 Void done() {                          /* Goal has now been achieved       */
2050     if (quiet)
2051       return;
2052 #if EXPLAIN_INSTANCE_RESOLUTION
2053     if (showInstRes)
2054       return;
2055 #endif
2056     if (useDots) {
2057         while (maxPos>currPos++)
2058             Putchar('.');
2059         Putchar('\n');
2060     }
2061     else
2062         for (; charCount>0; charCount--) {
2063             Putchar('\b');
2064             Putchar(' ');
2065             Putchar('\b');
2066         }
2067     aiming = FALSE;
2068     FlushStdout();
2069 }
2070
2071 static Void local failed() {           /* Goal cannot be reached due to    */
2072     if (aiming) {                      /* errors                           */
2073         aiming = FALSE;
2074         Putchar('\n');
2075         FlushStdout();
2076     }
2077 }
2078
2079 /* --------------------------------------------------------------------------
2080  * Error handling:
2081  * ------------------------------------------------------------------------*/
2082
2083 Void errHead(l)                        /* print start of error message     */
2084 Int l; {
2085     failed();                          /* failed to reach target ...       */
2086     stopAnyPrinting();
2087     FPrintf(errorStream,"ERROR");
2088
2089     if (scriptFile) {
2090         FPrintf(errorStream," \"%s\"", scriptFile);
2091         setLastEdit(scriptFile,l);
2092         if (l) FPrintf(errorStream," (line %d)",l);
2093         scriptFile = 0;
2094     }
2095     FPrintf(errorStream,": ");
2096     FFlush(errorStream);
2097 }
2098
2099 Void errFail() {                        /* terminate error message and     */
2100     Putc('\n',errorStream);             /* produce exception to return to  */
2101     FFlush(errorStream);                /* main command loop               */
2102     longjmp(catch_error,1);
2103 }
2104
2105 Void errAbort() {                       /* altern. form of error handling  */
2106     failed();                           /* used when suitable error message*/
2107     stopAnyPrinting();                  /* has already been printed        */
2108     errFail();
2109 }
2110
2111 Void internal(msg)                      /* handle internal error           */
2112 String msg; {
2113 #if HUGS_FOR_WINDOWS
2114     char buf[300];
2115     wsprintf(buf,"INTERNAL ERROR: %s",msg);
2116     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2117 #endif
2118     failed();
2119     stopAnyPrinting();
2120     Printf("INTERNAL ERROR: %s\n",msg);
2121     FlushStdout();
2122     longjmp(catch_error,1);
2123 }
2124
2125 Void fatal(msg)                         /* handle fatal error              */
2126 String msg; {
2127 #if HUGS_FOR_WINDOWS
2128     char buf[300];
2129     wsprintf(buf,"FATAL ERROR: %s",msg);
2130     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
2131 #endif
2132     FlushStdout();
2133     Printf("\nFATAL ERROR: %s\n",msg);
2134     everybody(EXIT);
2135     exit(1);
2136 }
2137
2138 sigHandler(breakHandler) {              /* respond to break interrupt      */
2139 #if HUGS_FOR_WINDOWS
2140     MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
2141 #endif
2142     Hilite();
2143     Printf("{Interrupted!}\n");
2144     Lolite();
2145     breakOn(TRUE);  /* reinstall signal handler - redundant on BSD systems */
2146                     /* but essential on POSIX (and other?) systems         */
2147     everybody(BREAK);
2148     failed();
2149     stopAnyPrinting();
2150     FlushStdout();
2151     clearerr(stdin);
2152     longjmp(catch_error,1);
2153     sigResume;/*NOTREACHED*/
2154 }
2155
2156 /* --------------------------------------------------------------------------
2157  * Read value from environment variable or registry:
2158  * ------------------------------------------------------------------------*/
2159
2160 String fromEnv(var,def)         /* return value of:                        */
2161 String var;                     /*     environment variable named by var   */
2162 String def; {                   /* or: default value given by def          */
2163     String s = getenv(var);
2164     return (s ? s : def);
2165 }
2166
2167 /* --------------------------------------------------------------------------
2168  * String manipulation routines:
2169  * ------------------------------------------------------------------------*/
2170
2171 static String local strCopy(s)         /* make malloced copy of a string   */
2172 String s; {
2173     if (s && *s) {
2174         char *t, *r;
2175         if ((t=(char *)malloc(strlen(s)+1))==0) {
2176             ERRMSG(0) "String storage space exhausted"
2177             EEND;
2178         }
2179         for (r=t; (*r++ = *s++)!=0; ) {
2180         }
2181         return t;
2182     }
2183     return NULL;
2184 }
2185
2186 /* --------------------------------------------------------------------------
2187  * Compiler output
2188  * We can redirect compiler output (prompts, error messages, etc) by
2189  * tweaking these functions.
2190  * ------------------------------------------------------------------------*/
2191
2192 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
2193
2194 #ifdef HAVE_STDARG_H
2195 #include <stdarg.h>
2196 #else
2197 #include <varargs.h>
2198 #endif
2199
2200 /* ----------------------------------------------------------------------- */
2201
2202 #define BufferSize 10000              /* size of redirected output buffer  */
2203
2204 typedef struct _HugsStream {
2205     char buffer[BufferSize];          /* buffer for redirected output      */
2206     Int  next;                        /* next space in buffer              */
2207 } HugsStream;
2208
2209 static Void   local vBufferedPrintf  Args((HugsStream*, const char*, va_list));
2210 static Void   local bufferedPutchar  Args((HugsStream*, Char));
2211 static String local bufferClear      Args((HugsStream *stream));
2212
2213 static Void local vBufferedPrintf(stream, fmt, ap)
2214 HugsStream* stream;
2215 const char* fmt;
2216 va_list     ap; {
2217     Int spaceLeft = BufferSize - stream->next;
2218     char* p = &stream->buffer[stream->next];
2219     Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
2220     if (0 <= charsAdded && charsAdded < spaceLeft)
2221         stream->next += charsAdded;
2222 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
2223     else
2224         stream->next = 0;
2225 #endif
2226 }
2227
2228 static Void local bufferedPutchar(stream, c)
2229 HugsStream *stream;
2230 Char        c; {
2231     if (BufferSize - stream->next >= 2) {
2232         stream->buffer[stream->next++] = c;
2233         stream->buffer[stream->next] = '\0';
2234     }
2235 }
2236
2237 static String local bufferClear(stream)
2238 HugsStream *stream; {
2239     if (stream->next == 0) {
2240         return "";
2241     } else {
2242         stream->next = 0;
2243         return stream->buffer;
2244     }
2245 }
2246
2247 /* ----------------------------------------------------------------------- */
2248
2249 static HugsStream outputStreamH;
2250 /* ADR note:
2251  * We rely on standard C semantics to initialise outputStreamH.next to 0.
2252  */
2253
2254 Void hugsEnableOutput(f)
2255 Bool f; {
2256     disableOutput = !f;
2257 }
2258
2259 String hugsClearOutputBuffer() {
2260     return bufferClear(&outputStreamH);
2261 }
2262
2263 #ifdef HAVE_STDARG_H
2264 Void hugsPrintf(const char *fmt, ...) {
2265     va_list ap;                    /* pointer into argument list           */
2266     va_start(ap, fmt);             /* make ap point to first arg after fmt */
2267     if (!disableOutput) {
2268         vprintf(fmt, ap);
2269     } else {
2270         vBufferedPrintf(&outputStreamH, fmt, ap);
2271     }
2272     va_end(ap);                    /* clean up                             */
2273 }
2274 #else
2275 Void hugsPrintf(fmt, va_alist)
2276 const char *fmt;
2277 va_dcl {
2278     va_list ap;                    /* pointer into argument list           */
2279     va_start(ap);                  /* make ap point to first arg after fmt */
2280     if (!disableOutput) {
2281         vprintf(fmt, ap);
2282     } else {
2283         vBufferedPrintf(&outputStreamH, fmt, ap);
2284     }
2285     va_end(ap);                    /* clean up                             */
2286 }
2287 #endif
2288
2289 Void hugsPutchar(c)
2290 int c; {
2291     if (!disableOutput) {
2292         putchar(c);
2293     } else {
2294         bufferedPutchar(&outputStreamH, c);
2295     }
2296 }
2297
2298 Void hugsFlushStdout() {
2299     if (!disableOutput) {
2300         fflush(stdout);
2301     }
2302 }
2303
2304 Void hugsFFlush(fp)
2305 FILE* fp; {
2306     if (!disableOutput) {
2307         fflush(fp);
2308     }
2309 }
2310
2311 #ifdef HAVE_STDARG_H
2312 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
2313     va_list ap;
2314     va_start(ap, fmt);
2315     if (!disableOutput) {
2316         vfprintf(fp, fmt, ap);
2317     } else {
2318         vBufferedPrintf(&outputStreamH, fmt, ap);
2319     }
2320     va_end(ap);
2321 }
2322 #else
2323 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
2324 FILE* fp;
2325 const char* fmt;
2326 va_dcl {
2327     va_list ap;
2328     va_start(ap);
2329     if (!disableOutput) {
2330         vfprintf(fp, fmt, ap);
2331     } else {
2332         vBufferedPrintf(&outputStreamH, fmt, ap);
2333     }
2334     va_end(ap);
2335 }
2336 #endif
2337
2338 Void hugsPutc(c, fp)
2339 int   c;
2340 FILE* fp; {
2341     if (!disableOutput) {
2342         putc(c,fp);
2343     } else {
2344         bufferedPutchar(&outputStreamH, c);
2345     }
2346 }
2347
2348 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
2349 /* --------------------------------------------------------------------------
2350  * Send message to each component of system:
2351  * ------------------------------------------------------------------------*/
2352
2353 Void everybody(what)            /* send command `what' to each component of*/
2354 Int what; {                     /* system to respond as appropriate ...    */
2355     machdep(what);              /* The order of calling each component is  */
2356     storage(what);              /* important for the INSTALL command       */
2357     substitution(what);
2358     input(what);
2359     translateControl(what);
2360     linkControl(what);
2361     staticAnalysis(what);
2362     deriveControl(what);
2363     typeChecker(what);
2364     compiler(what);
2365     codegen(what);
2366 }
2367
2368 /* --------------------------------------------------------------------------
2369  * Hugs for Windows code (WinMain and related functions)
2370  * ------------------------------------------------------------------------*/
2371
2372 #if HUGS_FOR_WINDOWS
2373 #include "winhugs.c"
2374 #endif