ghc/interpreter/hugs.c

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