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