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