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