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.4 $
  12  * $Date: 1999/03/01 14:46:45 $
  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    scriptBase;               /* Number of scripts in Prelude    */
 116 static Int    numScripts;               /* Number of scripts loaded        */
 117 static Int    namesUpto;                /* Number of script names set      */
 118 static Bool   needsImports;             /* set to TRUE if imports required */
 119        String scriptFile;               /* Name of current script (if any) */
 120
 121 static Text   evalModule  = 0;          /* Name of module we eval exprs in */
 122 static String currProject = 0;          /* Name of current project file    */
 123 static Bool   projectLoaded = FALSE;    /* TRUE => project file loaded     */
 124
 125 static String lastEdit   = 0;           /* Name of script to edit (if any) */
 126 static Int    lastEdLine = 0;           /* Editor line number (if possible)*/
 127 static String prompt     = 0;           /* Prompt string                   */
 128 static Int    hpSize     = DEFAULTHEAP; /* Desired heap size               */
 129 String hugsEdit = 0;                    /* String for editor command       */
 130 String hugsPath = 0;                    /* String for file search path     */
 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("HUGSFLAGS",""));
 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     scriptBase = numScripts;
 266 }
 267
 268 /* --------------------------------------------------------------------------
 269  * Command line options:
 270  * ------------------------------------------------------------------------*/
 271
 272 struct options {                        /* command line option toggles     */
 273     char   c;                           /* table defined in main app.      */
 274     String description;
 275     Bool   *flag;
 276 };
 277 extern struct options toggle[];
 278
 279 static Void local toggleSet(c,state)    /* Set command line toggle         */
 280 Char c;
 281 Bool state; {
 282     Int i;
 283     for (i=0; toggle[i].c; ++i)
 284         if (toggle[i].c == c) {
 285             *toggle[i].flag = state;
 286             return;
 287         }
 288     ERRMSG(0) "Unknown toggle `%c'", c
 289     EEND;
 290 }
 291
 292 static Void local togglesIn(state)      /* Print current list of toggles in*/
 293 Bool state; {                           /* given state                     */
 294     Int count = 0;
 295     Int i;
 296     for (i=0; toggle[i].c; ++i)
 297         if (*toggle[i].flag == state) {
 298             if (count==0)
 299                 Putchar((char)(state ? '+' : '-'));
 300             Putchar(toggle[i].c);
 301             count++;
 302         }
 303     if (count>0)
 304         Putchar(' ');
 305 }
 306
 307 static Void local optionInfo() {        /* Print information about command */
 308     static String fmts = "%-5s%s\n";    /* line settings                   */
 309     static String fmtc = "%-5c%s\n";
 310     Int    i;
 311
 312     Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
 313     for (i=0; toggle[i].c; ++i)
 314         Printf(fmtc,toggle[i].c,toggle[i].description);
 315
 316     Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
 317     Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
 318     Printf(fmts,"pstr","Set prompt string to str");
 319     Printf(fmts,"rstr","Set repeat last expression string to str");
 320     Printf(fmts,"Pstr","Set search path for modules to str");
 321     Printf(fmts,"Estr","Use editor setting given by str");
 322     Printf(fmts,"cnum","Set constraint cutoff limit");
 323 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 324     Printf(fmts,"Fstr","Set preprocessor filter to str");
 325 #endif
 326 #if PROFILING
 327     Printf(fmts,"dnum","Gather profiling statistics every <num> reductions\n");
 328 #endif
 329
 330     Printf("\nCurrent settings: ");
 331     togglesIn(TRUE);
 332     togglesIn(FALSE);
 333     Printf("-h%d",heapSize);
 334     Printf(" -p");
 335     printString(prompt);
 336     Printf(" -r");
 337     printString(repeatStr);
 338     Printf(" -c%d",cutoff);
 339     Printf("\nSearch path     : -P");
 340     printString(hugsPath);
 341 #if 0
 342 ToDo
 343     if (projectPath!=NULL) {
 344         Printf("\nProject Path    : %s",projectPath);
 345     }
 346 #endif
 347     Printf("\nEditor setting  : -E");
 348     printString(hugsEdit);
 349 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 350     Printf("\nPreprocessor    : -F");
 351     printString(preprocessor);
 352 #endif
 353 #if PROFILING
 354     Printf("\nProfile interval: -d%d", profiling ? profInterval : 0);
 355 #endif
 356     Printf("\nCompatibility   : %s", haskell98 ? "Haskell 98"
 357                                                : "Hugs Extensions");
 358     Putchar('\n');
 359 }
 360
 361 #if USE_REGISTRY || HUGS_FOR_WINDOWS
 362 #define PUTC(c)                         \
 363     *next++=(c)
 364
 365 #define PUTS(s)                         \
 366     strcpy(next,s);                     \
 367     next+=strlen(next)
 368
 369 #define PUTInt(optc,i)                  \
 370     sprintf(next,"-%c%d",optc,i);       \
 371     next+=strlen(next)
 372
 373 #define PUTStr(c,s)                     \
 374     next=PUTStr_aux(next,c,s)
 375
 376 static String local PUTStr_aux Args((String,Char, String));
 377
 378 static String local PUTStr_aux(next,c,s)
 379 String next;
 380 Char   c;
 381 String s; {
 382     if (s) {
 383         String t = 0;
 384         sprintf(next,"-%c\"",c);
 385         next+=strlen(next);
 386         for(t=s; *t; ++t) {
 387             PUTS(unlexChar(*t,'"'));
 388         }
 389         next+=strlen(next);
 390         PUTS("\" ");
 391     }
 392     return next;
 393 }
 394
 395 static String local optionsToStr() {          /* convert options to string */
 396     static char buffer[2000];
 397     String next = buffer;
 398
 399     Int i;
 400     for (i=0; toggle[i].c; ++i) {
 401         PUTC(*toggle[i].flag ? '+' : '-');
 402         PUTC(toggle[i].c);
 403         PUTC(' ');
 404     }
 405     PUTInt('h',hpSize);  PUTC(' ');
 406     PUTStr('p',prompt);
 407     PUTStr('r',repeatStr);
 408     PUTStr('P',hugsPath);
 409     PUTStr('E',hugsEdit);
 410     PUTInt('c',cutoff);  PUTC(' ');
 411 #if USE_PREPROCESSOR  && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
 412     PUTStr('F',preprocessor);
 413 #endif
 414 #if PROFILING
 415     PUTInt('d',profiling ? profInterval : 0);
 416 #endif
 417     PUTC('\0');
 418     return buffer;
 419 }
 420 #endif /* USE_REGISTRY */
 421
 422 #undef PUTC
 423 #undef PUTS
 424 #undef PUTInt
 425 #undef PUTStr
 426
 427 static Void local readOptions(options)         /* read options from string */
 428 String options; {
 429     String s;
 430     if (options) {
 431         stringInput(options);
 432         while ((s=readFilename())!=0) {
 433             if (*s && !processOption(s)) {
 434                 ERRMSG(0) "Option string must begin with `+' or `-'"
 435                 EEND;
 436             }
 437         }
 438     }
 439 }
 440
 441 static Bool local processOption(s)      /* process string s for options,   */
 442 String s; {                             /* return FALSE if none found.     */
 443     Bool state;
 444
 445     if (s[0]=='-')
 446         state = FALSE;
 447     else if (s[0]=='+')
 448         state = TRUE;
 449     else
 450         return FALSE;
 451
 452     while (*++s)
 453         switch (*s) {
 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 #if !IGNORE_MODULES
 599  {":module",SETMODULE},
 600 #endif
 601  {"",      EVAL},
 602  {0,0}
 603 };
 604
 605 static Void local menu() {
 606     Printf("LIST OF COMMANDS:  Any command may be abbreviated to :c where\n");
 607     Printf("c is the first character in the full name.\n\n");
 608     Printf(":load <filenames>   load modules from specified files\n");
 609     Printf(":load               clear all files except prelude\n");
 610     Printf(":also <filenames>   read additional modules\n");
 611     Printf(":reload             repeat last load command\n");
 612     Printf(":project <filename> use project file\n");
 613     Printf(":edit <filename>    edit file\n");
 614     Printf(":edit               edit last module\n");
 615 #if !IGNORE_MODULES
 616     Printf(":module <module>    set module for evaluating expressions\n");
 617 #endif
 618     Printf("<expr>              evaluate expression\n");
 619     Printf(":type <expr>        print type of expression\n");
 620     Printf(":?                  display this list of commands\n");
 621     Printf(":set <options>      set command line options\n");
 622     Printf(":set                help on command line options\n");
 623     Printf(":names [pat]        list names currently in scope\n");
 624     Printf(":info <names>       describe named objects\n");
 625     Printf(":find <name>        edit module containing definition of name\n");
 626     Printf(":!command           shell escape\n");
 627     Printf(":cd dir             change directory\n");
 628     Printf(":gc                 force garbage collection\n");
 629     Printf(":quit               exit Hugs interpreter\n");
 630 }
 631
 632 static Void local guidance() {
 633     Printf("Command not recognised.  ");
 634     forHelp();
 635 }
 636
 637 static Void local forHelp() {
 638     Printf("Type :? for help\n");
 639 }
 640
 641 /* --------------------------------------------------------------------------
 642  * Setting of command line options:
 643  * ------------------------------------------------------------------------*/
 644
 645 struct options toggle[] = {             /* List of command line toggles    */
 646     {'s', "Print no. reductions/cells after eval", &showStats},
 647     {'t', "Print type after evaluation",           &addType},
 648     /*ToDo??    {'f', "Terminate evaluation on first error",   &failOnError},*/
 649     {'g', "Print no. cells recovered after gc",    &gcMessages},
 650     {'l', "Literate modules as default",           &literateScripts},
 651     {'e', "Warn about errors in literate modules", &literateErrors},
 652     {'.', "Print dots to show progress",           &useDots},
 653     {'q', "Print nothing to show progress",        &quiet},
 654     {'w', "Always show which modules are loaded",  &listScripts},
 655     {'k', "Show kind errors in full",              &kindExpert},
 656     {'o', "Allow overlapping instances",           &allowOverlap},
 657     {'i', "Chase imports while loading modules",   &chaseImports},
 658 #if DEBUG_CODE
 659     {'D', "Debug: show generated code",            &debugCode},
 660 #endif
 661     {0,   0,                                       0}
 662 };
 663
 664 static Void local set() {               /* change command line options from*/
 665     String s;                           /* Hugs command line               */
 666
 667     if ((s=readFilename())!=0) {
 668         do {
 669             if (!processOption(s)) {
 670                 ERRMSG(0) "Option string must begin with `+' or `-'"
 671                 EEND;
 672             }
 673         } while ((s=readFilename())!=0);
 674 #if USE_REGISTRY
 675         writeRegString("Options", optionsToStr());
 676 #endif
 677     }
 678     else
 679         optionInfo();
 680 }
 681
 682 /* --------------------------------------------------------------------------
 683  * Change directory command:
 684  * ------------------------------------------------------------------------*/
 685
 686 static Void local changeDir() {         /* change directory                */
 687     String s = readFilename();
 688     if (s && chdir(s)) {
 689         ERRMSG(0) "Unable to change to directory \"%s\"", s
 690         EEND;
 691     }
 692 }
 693
 694 /* --------------------------------------------------------------------------
 695  * Loading project and script files:
 696  * ------------------------------------------------------------------------*/
 697
 698 static Void local loadProject(s)        /* Load project file               */
 699 String s; {
 700     clearProject();
 701     currProject = s;
 702     projInput(currProject);
 703     scriptFile = currProject;
 704     forgetScriptsFrom(scriptBase);
 705     while ((s=readFilename())!=0)
 706         addScriptName(s,TRUE);
 707     if (namesUpto<=1) {
 708         ERRMSG(0) "Empty project file"
 709         EEND;
 710     }
 711     scriptFile    = 0;
 712     projectLoaded = TRUE;
 713 }
 714
 715 static Void local clearProject() {      /* clear name for current project  */
 716     if (currProject)
 717         free(currProject);
 718     currProject   = 0;
 719     projectLoaded = FALSE;
 720 #if HUGS_FOR_WINDOWS
 721     setLastEdit((String)0,0);
 722 #endif
 723 }
 724
 725 static Void local addScriptName(s,sch)  /* Add script to list of scripts   */
 726 String s;                               /* to be read in ...               */
 727 Bool   sch; {                           /* TRUE => requires pathname search*/
 728     if (namesUpto>=NUM_SCRIPTS) {
 729         ERRMSG(0) "Too many module files (maximum of %d allowed)",
 730                   NUM_SCRIPTS
 731         EEND;
 732     }
 733     else
 734         scriptName[namesUpto++] = strCopy(sch ? findPathname(NULL,s) : s);
 735 }
 736
 737 static Bool local addScript(fname,len)  /* read single script file         */
 738 String fname;                           /* name of script file             */
 739 Long   len; {                           /* length of script file           */
 740     scriptFile = fname;
 741
 742 #if HUGS_FOR_WINDOWS                    /* Set clock cursor while loading  */
 743     allowBreak();
 744     SetCursor(LoadCursor(NULL, IDC_WAIT));
 745 #endif
 746
 747     Printf("Reading file \"%s\":\n",fname);
 748     setLastEdit(fname,0);
 749
 750 #if 0
 751 ToDo: reinstate
 752     if (isInterfaceFile(fname)) {
 753         loadInterface(fname);
 754     } else
 755 #else
 756            {
 757         needsImports = FALSE;
 758         parseScript(fname,len);         /* process script file             */
 759         if (needsImports)
 760             return FALSE;
 761         checkDefns();
 762         typeCheckDefns();
 763         compileDefns();
 764     }
 765 #endif
 766     scriptFile = 0;
 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);
 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(scriptBase);
 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(scriptBase);
 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);
 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         startNewScript(scriptName[numScripts]);
 888         if (addScript(scriptName[numScripts],fileSize))
 889             numScripts++;
 890         else
 891             dropScriptsFrom(numScripts);
 892     }
 893
 894     if (listScripts)
 895         whatScripts();
 896     if (numScripts<=scriptBase)
 897         setLastEdit((String)0, 0);
 898 }
 899
 900 static Void local whatScripts() {       /* list scripts in current session */
 901     int i;
 902     Printf("\nHugs session for:");
 903     if (projectLoaded)
 904         Printf(" (project: %s)",currProject);
 905     for (i=0; i<numScripts; ++i)
 906         Printf("\n%s",scriptName[i]);
 907     Putchar('\n');
 908 }
 909
 910 /* --------------------------------------------------------------------------
 911  * Access to external editor:
 912  * ------------------------------------------------------------------------*/
 913
 914 static Void local editor() {            /* interpreter-editor interface    */
 915     String newFile  = readFilename();
 916     if (newFile) {
 917         setLastEdit(newFile,0);
 918         if (readFilename()) {
 919             ERRMSG(0) "Multiple filenames not permitted"
 920             EEND;
 921         }
 922     }
 923     runEditor();
 924 }
 925
 926 static Void local find() {              /* edit file containing definition */
 927     String nm = readFilename();         /* of specified name               */
 928     if (!nm) {
 929         ERRMSG(0) "No name specified"
 930         EEND;
 931     }
 932     else if (readFilename()) {
 933         ERRMSG(0) "Multiple names not permitted"
 934         EEND;
 935     }
 936     else {
 937         Text t;
 938         Cell c;
 939         setCurrModule(findEvalModule());
 940         startNewScript(0);
 941         if (nonNull(c=findTycon(t=findText(nm)))) {
 942             if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
 943                 readScripts(scriptBase);
 944             }
 945         } else if (nonNull(c=findName(t))) {
 946             if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
 947                 readScripts(scriptBase);
 948             }
 949         } else {
 950             ERRMSG(0) "No current definition for name \"%s\"", nm
 951             EEND;
 952         }
 953     }
 954 }
 955
 956 static Void local runEditor() {         /* run editor on script lastEdit   */
 957     if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine              */
 958         readScripts(scriptBase);
 959 }
 960
 961 static Void local setLastEdit(fname,line)/* keep name of last file to edit */
 962 String fname;
 963 Int    line; {
 964     if (lastEdit)
 965         free(lastEdit);
 966     lastEdit = strCopy(fname);
 967     lastEdLine = line;
 968 #if HUGS_FOR_WINDOWS
 969     DrawStatusLine(hWndMain);           /* Redo status line                */
 970 #endif
 971 }
 972
 973 /* --------------------------------------------------------------------------
 974  * Read and evaluate an expression:
 975  * ------------------------------------------------------------------------*/
 976
 977 #if !IGNORE_MODULES
 978 static Void local setModule(){/*set module in which to evaluate expressions*/
 979     String s = readFilename();
 980     if (!s) s = "";              /* :m clears the current module selection */
 981     evalModule = findText(s);
 982     setLastEdit(fileOfModule(findEvalModule()),0);
 983 }
 984
 985 static Module local findEvalModule() { /*Module in which to eval expressions*/
 986     Module m = findModule(evalModule);
 987     if (isNull(m))
 988         m = lastModule();
 989     return m;
 990 }
 991 #endif
 992
 993 static Void local evaluator() {        /* evaluate expr and print value    */
 994     Type  type, bd;
 995     Kinds ks   = NIL;
 996
 997     setCurrModule(findEvalModule());
 998     scriptFile = 0;
 999     startNewScript(0);                 /* Enables recovery of storage      */
1000                                        /* allocated during evaluation      */
1001     parseExp();
1002     checkExp();
1003     defaultDefns = evalDefaults;
1004     type         = typeCheckExp(TRUE);
1005     if (isPolyType(type)) {
1006         ks = polySigOf(type);
1007         bd = monotypeOf(type);
1008     }
1009     else
1010         bd = type;
1011
1012     if (whatIs(bd)==QUAL) {
1013         ERRMSG(0) "Unresolved overloading" ETHEN
1014         ERRTEXT   "\n*** Type       : "    ETHEN ERRTYPE(type);
1015         ERRTEXT   "\n*** Expression : "    ETHEN ERREXPR(inputExpr);
1016         ERRTEXT   "\n"
1017         EEND;
1018     }
1019
1020 #if PROFILING
1021     if (profiling)
1022         profilerLog("profile.hp");
1023     numReductions = 0;
1024     garbageCollect();
1025 #endif
1026
1027 #ifdef WANT_TIMER
1028     updateTimers();
1029 #endif
1030
1031 #if 1
1032     if (typeMatches(type,ap(typeIO,typeUnit))) {
1033         inputExpr = ap(nameRunIO,inputExpr);
1034         evalExp();
1035         Putchar('\n');
1036     } else {
1037         Cell d = provePred(ks,NIL,ap(classShow,bd));
1038         if (isNull(d)) {
1039             ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
1040             ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
1041             ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
1042             ERRTEXT   "\n"
1043             EEND;
1044         }
1045         //inputExpr = ap2(namePrint,d,inputExpr);
1046         //inputExpr = ap(nameRunIO,inputExpr);
1047
1048         inputExpr = ap2(findName(findText("show")),d,inputExpr);
1049         inputExpr = ap(findName(findText("putStr")), inputExpr);
1050         inputExpr = ap(nameRunIO, inputExpr);
1051
1052         evalExp(); printf("\n");
1053         if (addType) {
1054             printf(" :: ");
1055             printType(stdout,type);
1056             Putchar('\n');
1057         }
1058     }
1059 #endif
1060
1061 #if 0
1062    printf ( "result type is " );
1063    printType ( stdout, type );
1064    printf ( "\n" );
1065    evalExp();
1066    printf ( "\n" );
1067 #endif
1068
1069 }
1070
1071 static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
1072     if (printing) {                    /* after successful termination or  */
1073         printing = FALSE;              /* runtime error (e.g. interrupt)   */
1074         Putchar('\n');
1075         if (showStats) {
1076 #define plural(v)   v, (v==1?"":"s")
1077           /* Printf("(%lu reduction%s, ",plural(numReductions)); */
1078             Printf("%lu cell%s",plural(numCells));
1079             if (numGcs>0)
1080                 Printf(", %u garbage collection%s",plural(numGcs));
1081             Printf(")\n");
1082 #undef plural
1083         }
1084         FlushStdout();
1085         garbageCollect();
1086     }
1087 }
1088
1089 /* --------------------------------------------------------------------------
1090  * Print type of input expression:
1091  * ------------------------------------------------------------------------*/
1092
1093 static Void local showtype() {         /* print type of expression (if any)*/
1094     Cell type;
1095
1096     setCurrModule(findEvalModule());
1097     startNewScript(0);                 /* Enables recovery of storage      */
1098                                        /* allocated during evaluation      */
1099     parseExp();
1100     checkExp();
1101     defaultDefns = evalDefaults;
1102     type = typeCheckExp(FALSE);
1103     printExp(stdout,inputExpr);
1104     Printf(" :: ");
1105     printType(stdout,type);
1106     Putchar('\n');
1107 }
1108
1109 /* --------------------------------------------------------------------------
1110  * Enhanced help system:  print current list of scripts or give information
1111  * about an object.
1112  * ------------------------------------------------------------------------*/
1113
1114 static String local objToStr(m,c)
1115 Module m;
1116 Cell   c; {
1117 #if 1 || DISPLAY_QUANTIFIERS
1118     static char newVar[60];
1119     switch (whatIs(c)) {
1120         case NAME  : if (m == name(c).mod) {
1121                          sprintf(newVar,"%s", textToStr(name(c).text));
1122                      } else {
1123                          sprintf(newVar,"%s.%s",
1124                                         textToStr(module(name(c).mod).text),
1125                                         textToStr(name(c).text));
1126                      }
1127                      break;
1128
1129         case TYCON : if (m == tycon(c).mod) {
1130                          sprintf(newVar,"%s", textToStr(tycon(c).text));
1131                      } else {
1132                          sprintf(newVar,"%s.%s",
1133                                         textToStr(module(tycon(c).mod).text),
1134                                         textToStr(tycon(c).text));
1135                      }
1136                      break;
1137
1138         case CLASS : if (m == cclass(c).mod) {
1139                          sprintf(newVar,"%s", textToStr(cclass(c).text));
1140                      } else {
1141                          sprintf(newVar,"%s.%s",
1142                                         textToStr(module(cclass(c).mod).text),
1143                                         textToStr(cclass(c).text));
1144                      }
1145                      break;
1146
1147         default    : internal("objToStr");
1148     }
1149     return newVar;
1150 #else
1151     static char newVar[33];
1152     switch (whatIs(c)) {
1153         case NAME  : sprintf(newVar,"%s", textToStr(name(c).text));
1154                      break;
1155
1156         case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
1157                      break;
1158
1159         case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
1160                      break;
1161
1162         default    : internal("objToStr");
1163     }
1164     return newVar;
1165 #endif
1166 }
1167
1168 static Void local info() {              /* describe objects                */
1169     Int    count = 0;                   /* or give menu of commands        */
1170     String s;
1171
1172     setCurrModule(findEvalModule());
1173     startNewScript(0);                  /* for recovery of storage         */
1174     for (; (s=readFilename())!=0; count++) {
1175         describe(findText(s));
1176     }
1177     if (count == 0) {
1178         whatScripts();
1179     }
1180 }
1181
1182 static Void local describe(t)           /* describe an object              */
1183 Text t; {
1184     Tycon  tc  = findTycon(t);
1185     Class  cl  = findClass(t);
1186     Name   nm  = findName(t);
1187     //Module mod = findEvalModule();
1188
1189     if (nonNull(tc)) {                  /* as a type constructor           */
1190         Type t = tc;
1191         Int  i;
1192         Inst in;
1193         for (i=0; i<tycon(tc).arity; ++i) {
1194             t = ap(t,mkOffset(i));
1195         }
1196         Printf("-- type constructor");
1197         if (kindExpert) {
1198             Printf(" with kind ");
1199             printKind(stdout,tycon(tc).kind);
1200         }
1201         Putchar('\n');
1202         switch (tycon(tc).what) {
1203             case SYNONYM      : Printf("type ");
1204                                 printType(stdout,t);
1205                                 Printf(" = ");
1206                                 printType(stdout,tycon(tc).defn);
1207                                 break;
1208
1209             case NEWTYPE      :
1210             case DATATYPE     : {   List cs = tycon(tc).defn;
1211                                     if (tycon(tc).what==DATATYPE) {
1212                                         Printf("data ");
1213                                     } else {
1214                                         Printf("newtype ");
1215                                     }
1216                                     printType(stdout,t);
1217                                     Putchar('\n');
1218                                     mapProc(printSyntax,cs);
1219                                     if (hasCfun(cs)) {
1220                                         Printf("\n-- constructors:");
1221                                     }
1222                                     for (; hasCfun(cs); cs=tl(cs)) {
1223                                         Putchar('\n');
1224                                         printExp(stdout,hd(cs));
1225                                         Printf(" :: ");
1226                                         printType(stdout,name(hd(cs)).type);
1227                                     }
1228                                     if (nonNull(cs)) {
1229                                         Printf("\n-- selectors:");
1230                                     }
1231                                     for (; nonNull(cs); cs=tl(cs)) {
1232                                         Putchar('\n');
1233                                         printExp(stdout,hd(cs));
1234                                         Printf(" :: ");
1235                                         printType(stdout,name(hd(cs)).type);
1236                                     }
1237                                 }
1238                                 break;
1239
1240             case RESTRICTSYN  : Printf("type ");
1241                                 printType(stdout,t);
1242                                 Printf(" = <restricted>");
1243                                 break;
1244         }
1245         Putchar('\n');
1246         if (nonNull(in=findFirstInst(tc))) {
1247             Printf("\n-- instances:\n");
1248             do {
1249                 showInst(in);
1250                 in = findNextInst(tc,in);
1251             } while (nonNull(in));
1252         }
1253         Putchar('\n');
1254     }
1255
1256     if (nonNull(cl)) {                  /* as a class                      */
1257         List  ins = cclass(cl).instances;
1258         Kinds ks  = cclass(cl).kinds;
1259         if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
1260             Printf("-- type class");
1261         } else {
1262             Printf("-- constructor class");
1263             if (kindExpert) {
1264                 Printf(" with arity ");
1265                 printKinds(stdout,ks);
1266             }
1267         }
1268         Putchar('\n');
1269         mapProc(printSyntax,cclass(cl).members);
1270         Printf("class ");
1271         if (nonNull(cclass(cl).supers)) {
1272             printContext(stdout,cclass(cl).supers);
1273             Printf(" => ");
1274         }
1275         printPred(stdout,cclass(cl).head);
1276         if (nonNull(cclass(cl).members)) {
1277             List ms = cclass(cl).members;
1278             Printf(" where");
1279             do {
1280                 Type t = monotypeOf(name(hd(ms)).type);
1281                 Printf("\n  ");
1282                 printExp(stdout,hd(ms));
1283                 Printf(" :: ");
1284                 if (isNull(tl(fst(snd(t))))) {
1285                     t = snd(snd(t));
1286                 } else {
1287                     t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
1288                 }
1289                 printType(stdout,t);
1290                 ms = tl(ms);
1291             } while (nonNull(ms));
1292         }
1293         Putchar('\n');
1294         if (nonNull(ins)) {
1295             Printf("\n-- instances:\n");
1296             do {
1297                 showInst(hd(ins));
1298                 ins = tl(ins);
1299             } while (nonNull(ins));
1300         }
1301         Putchar('\n');
1302     }
1303
1304     if (nonNull(nm)) {                  /* as a function/name              */
1305         printSyntax(nm);
1306         printExp(stdout,nm);
1307         Printf(" :: ");
1308         if (nonNull(name(nm).type)) {
1309             printType(stdout,name(nm).type);
1310         } else {
1311             Printf("<unknown type>");
1312         }
1313
1314         if (isCfun(nm)) {
1315             Printf("  -- data constructor");
1316         } else if (isMfun(nm)) {
1317             Printf("  -- class member");
1318         } else if (isSfun(nm)) {
1319             Printf("  -- selector function");
1320         }
1321 #if 0
1322     ToDo: reinstate
1323         if (name(nm).primDef) {
1324             Printf("   -- primitive");
1325         }
1326 #endif
1327         Printf("\n\n");
1328     }
1329
1330     if (isNull(tc) && isNull(cl) && isNull(nm)) {
1331         Printf("Unknown reference `%s'\n",textToStr(t));
1332     }
1333 }
1334
1335 static Void local printSyntax(nm)
1336 Name nm; {
1337     Syntax sy = syntaxOf(nm);
1338     Text   t  = name(nm).text;
1339     String s  = textToStr(t);
1340     if (sy != defaultSyntax(t)) {
1341         Printf("infix");
1342         switch (assocOf(sy)) {
1343             case LEFT_ASS  : Putchar('l'); break;
1344             case RIGHT_ASS : Putchar('r'); break;
1345             case NON_ASS   : break;
1346         }
1347         Printf(" %i ",precOf(sy));
1348         if (isascii((int)(*s)) && isalpha((int)(*s))) {
1349             Printf("`%s`",s);
1350         } else {
1351             Printf("%s",s);
1352         }
1353         Putchar('\n');
1354     }
1355 }
1356
1357 static Void local showInst(in)          /* Display instance decl header    */
1358 Inst in; {
1359     Printf("instance ");
1360     if (nonNull(inst(in).specifics)) {
1361         printContext(stdout,inst(in).specifics);
1362         Printf(" => ");
1363     }
1364     printPred(stdout,inst(in).head);
1365     Putchar('\n');
1366 }
1367
1368 /* --------------------------------------------------------------------------
1369  * List all names currently in scope:
1370  * ------------------------------------------------------------------------*/
1371
1372 static Void local listNames() {         /* list names matching optional pat*/
1373     String pat   = readFilename();
1374     List   names = NIL;
1375     Int    width = getTerminalWidth() - 1;
1376     Int    count = 0;
1377     Int    termPos;
1378     Module mod   = findEvalModule();
1379
1380     if (pat) {                          /* First gather names to list      */
1381         do {
1382             names = addNamesMatching(pat,names);
1383         } while ((pat=readFilename())!=0);
1384     } else {
1385         names = addNamesMatching((String)0,names);
1386     }
1387     if (isNull(names)) {                /* Then print them out             */
1388         ERRMSG(0) "No names selected"
1389         EEND;
1390     }
1391     for (termPos=0; nonNull(names); names=tl(names)) {
1392         String s = objToStr(mod,hd(names));
1393         Int    l = strlen(s);
1394         if (termPos+1+l>width) {
1395             Putchar('\n');
1396             termPos = 0;
1397         } else if (termPos>0) {
1398             Putchar(' ');
1399             termPos++;
1400         }
1401         Printf("%s",s);
1402         termPos += l;
1403         count++;
1404     }
1405     Printf("\n(%d names listed)\n", count);
1406 }
1407
1408 /* --------------------------------------------------------------------------
1409  * print a prompt and read a line of input:
1410  * ------------------------------------------------------------------------*/
1411
1412 static Void local promptForInput(moduleName)
1413 String moduleName; {
1414     char promptBuffer[1000];
1415 #if 1
1416     /* This is portable but could overflow buffer */
1417     sprintf(promptBuffer,prompt,moduleName);
1418 #else
1419     /* Works on ANSI C - but pre-ANSI compilers return a pointer to
1420      * promptBuffer instead.
1421      */
1422     if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
1423         /* Reset prompt to a safe default to avoid an infinite loop */
1424         free(prompt);
1425         prompt = strCopy("? ");
1426         internal("Combined prompt and evaluation module name too long");
1427     }
1428 #endif
1429     consoleInput(promptBuffer);
1430 }
1431
1432 /* --------------------------------------------------------------------------
1433  * main read-eval-print loop, with error trapping:
1434  * ------------------------------------------------------------------------*/
1435
1436 static jmp_buf catch_error;             /* jump buffer for error trapping  */
1437
1438 static Void local interpreter(argc,argv)/* main interpreter loop           */
1439 Int    argc;
1440 String argv[]; {
1441     Int errorNumber = setjmp(catch_error);
1442
1443     breakOn(TRUE);                      /* enable break trapping           */
1444     if (numScripts==0) {                /* only succeeds on first time,    */
1445         if (errorNumber)                /* before prelude has been loaded  */
1446             fatal("Unable to load prelude");
1447         initialize(argc,argv);
1448         forHelp();
1449     }
1450
1451     for (;;) {
1452         Command cmd;
1453         everybody(RESET);               /* reset to sensible initial state */
1454         dropScriptsFrom(numScripts);    /* remove partially loaded scripts */
1455
1456         promptForInput(textToStr(module(findEvalModule()).text));
1457
1458         cmd = readCommand(cmds, (Char)':', (Char)'!');
1459 #ifdef WANT_TIMER
1460         updateTimers();
1461 #endif
1462         switch (cmd) {
1463             case EDIT   : editor();
1464                           break;
1465             case FIND   : find();
1466                           break;
1467             case LOAD   : clearProject();
1468                           forgetScriptsFrom(scriptBase);
1469                           load();
1470                           break;
1471             case ALSO   : clearProject();
1472                           forgetScriptsFrom(numScripts);
1473                           load();
1474                           break;
1475             case RELOAD : readScripts(scriptBase);
1476                           break;
1477             case PROJECT: project();
1478                           break;
1479 #if !IGNORE_MODULES
1480             case SETMODULE :
1481                           setModule();
1482                           break;
1483 #endif
1484             case EVAL   : evaluator();
1485                           break;
1486             case TYPEOF : showtype();
1487                           break;
1488             case NAMES  : listNames();
1489                           break;
1490             case HELP   : menu();
1491                           break;
1492             case BADCMD : guidance();
1493                           break;
1494             case SET    : set();
1495                           break;
1496             case SYSTEM : if (shellEsc(readLine()))
1497                               Printf("Warning: Shell escape terminated abnormally\n");
1498                           break;
1499             case CHGDIR : changeDir();
1500                           break;
1501             case INFO   : info();
1502                           break;
1503             case QUIT   : return;
1504             case COLLECT: consGC = FALSE;
1505                           garbageCollect();
1506                           consGC = TRUE;
1507                           Printf("Garbage collection recovered %d cells\n",
1508                                  cellsRecovered);
1509                           break;
1510             case NOCMD  : break;
1511         }
1512 #ifdef WANT_TIMER
1513         updateTimers();
1514         Printf("Elapsed time (ms): %ld (user), %ld (system)\n",
1515                millisecs(userElapsed), millisecs(systElapsed));
1516 #endif
1517     }
1518     breakOn(FALSE);
1519 }
1520
1521 /* --------------------------------------------------------------------------
1522  * Display progress towards goal:
1523  * ------------------------------------------------------------------------*/
1524
1525 static Target currTarget;
1526 static Bool   aiming = FALSE;
1527 static Int    currPos;
1528 static Int    maxPos;
1529 static Int    charCount;
1530
1531 Void setGoal(what, t)                  /* Set goal for what to be t        */
1532 String what;
1533 Target t; {
1534     if (quiet) return;
1535     currTarget = (t?t:1);
1536     aiming     = TRUE;
1537     if (useDots) {
1538         currPos = strlen(what);
1539         maxPos  = getTerminalWidth() - 1;
1540         Printf("%s",what);
1541     }
1542     else
1543         for (charCount=0; *what; charCount++)
1544             Putchar(*what++);
1545     FlushStdout();
1546 }
1547
1548 Void soFar(t)                          /* Indicate progress towards goal   */
1549 Target t; {                            /* has now reached t                */
1550     if (quiet) return;
1551     if (useDots) {
1552         Int newPos = (Int)((maxPos * ((long)t))/currTarget);
1553
1554         if (newPos>maxPos)
1555             newPos = maxPos;
1556
1557         if (newPos>currPos) {
1558             do
1559                 Putchar('.');
1560             while (newPos>++currPos);
1561             FlushStdout();
1562         }
1563         FlushStdout();
1564     }
1565 }
1566
1567 Void done() {                          /* Goal has now been achieved       */
1568     if (quiet) return;
1569     if (useDots) {
1570         while (maxPos>currPos++)
1571             Putchar('.');
1572         Putchar('\n');
1573     }
1574     else
1575         for (; charCount>0; charCount--) {
1576             Putchar('\b');
1577             Putchar(' ');
1578             Putchar('\b');
1579         }
1580     aiming = FALSE;
1581     FlushStdout();
1582 }
1583
1584 static Void local failed() {           /* Goal cannot be reached due to    */
1585     if (aiming) {                      /* errors                           */
1586         aiming = FALSE;
1587         Putchar('\n');
1588         FlushStdout();
1589     }
1590 }
1591
1592 /* --------------------------------------------------------------------------
1593  * Error handling:
1594  * ------------------------------------------------------------------------*/
1595
1596 Void errHead(l)                        /* print start of error message     */
1597 Int l; {
1598     failed();                          /* failed to reach target ...       */
1599     stopAnyPrinting();
1600     FPrintf(errorStream,"ERROR");
1601
1602     if (scriptFile) {
1603         FPrintf(errorStream," \"%s\"", scriptFile);
1604         setLastEdit(scriptFile,l);
1605         if (l) FPrintf(errorStream," (line %d)",l);
1606         scriptFile = 0;
1607     }
1608     FPrintf(errorStream,": ");
1609     FFlush(errorStream);
1610 }
1611
1612 Void errFail() {                        /* terminate error message and     */
1613     Putc('\n',errorStream);             /* produce exception to return to  */
1614     FFlush(errorStream);                /* main command loop               */
1615     longjmp(catch_error,1);
1616 }
1617
1618 Void errAbort() {                       /* altern. form of error handling  */
1619     failed();                           /* used when suitable error message*/
1620     stopAnyPrinting();                  /* has already been printed        */
1621     errFail();
1622 }
1623
1624 Void internal(msg)                      /* handle internal error           */
1625 String msg; {
1626 #if HUGS_FOR_WINDOWS
1627     char buf[300];
1628     wsprintf(buf,"INTERNAL ERROR: %s",msg);
1629     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
1630 #endif
1631     failed();
1632     stopAnyPrinting();
1633     Printf("INTERNAL ERROR: %s\n",msg);
1634     FlushStdout();
1635     longjmp(catch_error,1);
1636 }
1637
1638 Void fatal(msg)                         /* handle fatal error              */
1639 String msg; {
1640 #if HUGS_FOR_WINDOWS
1641     char buf[300];
1642     wsprintf(buf,"FATAL ERROR: %s",msg);
1643     MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
1644 #endif
1645     FlushStdout();
1646     Printf("\nFATAL ERROR: %s\n",msg);
1647     everybody(EXIT);
1648     exit(1);
1649 }
1650
1651 sigHandler(breakHandler) {              /* respond to break interrupt      */
1652 #if HUGS_FOR_WINDOWS
1653     MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
1654 #endif
1655     Hilite();
1656     Printf("{Interrupted!}\n");
1657     Lolite();
1658     breakOn(TRUE);  /* reinstall signal handler - redundant on BSD systems */
1659                     /* but essential on POSIX (and other?) systems         */
1660     everybody(BREAK);
1661     failed();
1662     stopAnyPrinting();
1663     FlushStdout();
1664     clearerr(stdin);
1665     longjmp(catch_error,1);
1666     sigResume;/*NOTREACHED*/
1667 }
1668
1669 /* --------------------------------------------------------------------------
1670  * Read value from environment variable or registry:
1671  * ------------------------------------------------------------------------*/
1672
1673 String fromEnv(var,def)         /* return value of:                        */
1674 String var;                     /*     environment variable named by var   */
1675 String def; {                   /* or: default value given by def          */
1676     String s = getenv(var);
1677     return (s ? s : def);
1678 }
1679
1680 /* --------------------------------------------------------------------------
1681  * String manipulation routines:
1682  * ------------------------------------------------------------------------*/
1683
1684 static String local strCopy(s)         /* make malloced copy of a string   */
1685 String s; {
1686     if (s && *s) {
1687         char *t, *r;
1688         if ((t=(char *)malloc(strlen(s)+1))==0) {
1689             ERRMSG(0) "String storage space exhausted"
1690             EEND;
1691         }
1692         for (r=t; (*r++ = *s++)!=0; ) {
1693         }
1694         return t;
1695     }
1696     return NULL;
1697 }
1698
1699 /* --------------------------------------------------------------------------
1700  * Compiler output
1701  * We can redirect compiler output (prompts, error messages, etc) by
1702  * tweaking these functions.
1703  * ------------------------------------------------------------------------*/
1704
1705 #if REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS
1706
1707 #ifdef HAVE_STDARG_H
1708 #include <stdarg.h>
1709 #else
1710 #include <varargs.h>
1711 #endif
1712
1713 /* ----------------------------------------------------------------------- */
1714
1715 #define BufferSize 5000               /* size of redirected output buffer  */
1716
1717 typedef struct _HugsStream {
1718     char buffer[BufferSize];          /* buffer for redirected output      */
1719     Int  next;                        /* next space in buffer              */
1720 } HugsStream;
1721
1722 static Void   local vBufferedPrintf  Args((HugsStream*, const char*, va_list));
1723 static Void   local bufferedPutchar  Args((HugsStream*, Char));
1724 static String local bufferClear      Args((HugsStream *stream));
1725
1726 static Void local vBufferedPrintf(stream, fmt, ap)
1727 HugsStream* stream;
1728 const char* fmt;
1729 va_list     ap; {
1730     Int spaceLeft = BufferSize - stream->next;
1731     char* p = &stream->buffer[stream->next];
1732     Int charsAdded = vsnprintf(p, spaceLeft, fmt, ap);
1733     if (0 <= charsAdded && charsAdded < spaceLeft)
1734         stream->next += charsAdded;
1735 #if 1 /* we can either buffer the first n chars or buffer the last n chars */
1736     else
1737         stream->next = 0;
1738 #endif
1739 }
1740
1741 static Void local bufferedPutchar(stream, c)
1742 HugsStream *stream;
1743 Char        c; {
1744     if (BufferSize - stream->next >= 2) {
1745         stream->buffer[stream->next++] = c;
1746         stream->buffer[stream->next] = '\0';
1747     }
1748 }
1749
1750 static String local bufferClear(stream)
1751 HugsStream *stream; {
1752     if (stream->next == 0) {
1753         return "";
1754     } else {
1755         stream->next = 0;
1756         return stream->buffer;
1757     }
1758 }
1759
1760 /* ----------------------------------------------------------------------- */
1761
1762 static HugsStream outputStreamH;
1763 /* ADR note:
1764  * We rely on standard C semantics to initialise outputStreamH.next to 0.
1765  */
1766
1767 Void hugsEnableOutput(f)
1768 Bool f; {
1769     disableOutput = !f;
1770 }
1771
1772 String hugsClearOutputBuffer() {
1773     return bufferClear(&outputStreamH);
1774 }
1775
1776 #ifdef HAVE_STDARG_H
1777 Void hugsPrintf(const char *fmt, ...) {
1778     va_list ap;                    /* pointer into argument list           */
1779     va_start(ap, fmt);             /* make ap point to first arg after fmt */
1780     if (!disableOutput) {
1781         vprintf(fmt, ap);
1782     } else {
1783         vBufferedPrintf(&outputStreamH, fmt, ap);
1784     }
1785     va_end(ap);                    /* clean up                             */
1786 }
1787 #else
1788 Void hugsPrintf(fmt, va_alist)
1789 const char *fmt;
1790 va_dcl {
1791     va_list ap;                    /* pointer into argument list           */
1792     va_start(ap);                  /* make ap point to first arg after fmt */
1793     if (!disableOutput) {
1794         vprintf(fmt, ap);
1795     } else {
1796         vBufferedPrintf(&outputStreamH, fmt, ap);
1797     }
1798     va_end(ap);                    /* clean up                             */
1799 }
1800 #endif
1801
1802 Void hugsPutchar(c)
1803 int c; {
1804     if (!disableOutput) {
1805         putchar(c);
1806     } else {
1807         bufferedPutchar(&outputStreamH, c);
1808     }
1809 }
1810
1811 Void hugsFlushStdout() {
1812     if (!disableOutput) {
1813         fflush(stdout);
1814     }
1815 }
1816
1817 Void hugsFFlush(fp)
1818 FILE* fp; {
1819     if (!disableOutput) {
1820         fflush(fp);
1821     }
1822 }
1823
1824 #ifdef HAVE_STDARG_H
1825 Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
1826     va_list ap;
1827     va_start(ap, fmt);
1828     if (!disableOutput) {
1829         vfprintf(fp, fmt, ap);
1830     } else {
1831         vBufferedPrintf(&outputStreamH, fmt, ap);
1832     }
1833     va_end(ap);
1834 }
1835 #else
1836 Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
1837 FILE* fp;
1838 const char* fmt;
1839 va_dcl {
1840     va_list ap;
1841     va_start(ap);
1842     if (!disableOutput) {
1843         vfprintf(fp, fmt, ap);
1844     } else {
1845         vBufferedPrintf(&outputStreamH, fmt, ap);
1846     }
1847     va_end(ap);
1848 }
1849 #endif
1850
1851 Void hugsPutc(c, fp)
1852 int   c;
1853 FILE* fp; {
1854     if (!disableOutput) {
1855         putc(c,fp);
1856     } else {
1857         bufferedPutchar(&outputStreamH, c);
1858     }
1859 }
1860
1861 #endif /* REDIRECT_OUTPUT && !HUGS_FOR_WINDOWS */
1862 /* --------------------------------------------------------------------------
1863  * Send message to each component of system:
1864  * ------------------------------------------------------------------------*/
1865
1866 Void everybody(what)            /* send command `what' to each component of*/
1867 Int what; {                     /* system to respond as appropriate ...    */
1868     machdep(what);              /* The order of calling each component is  */
1869     storage(what);              /* important for the INSTALL command       */
1870     substitution(what);
1871     input(what);
1872     linkControl(what);
1873     staticAnalysis(what);
1874     deriveControl(what);
1875     typeChecker(what);
1876     translateControl(what);
1877     compiler(what);
1878     codegen(what);
1879 }
1880
1881
1882 /* --------------------------------------------------------------------------
1883  * Hugs for Windows code (WinMain and related functions)
1884  * ------------------------------------------------------------------------*/
1885
1886 #if HUGS_FOR_WINDOWS
1887 #include "winhugs.c"
1888 #endif
1889
1890 /*-------------------------------------------------------------------------*/
1891