/* --------------------------------------------------------------------------
 * hugs.c:	Copyright (c) Mark P Jones 1991-1998.   All rights reserved.
 *		See NOTICE for details and conditions of use etc...
 *		Hugs version 1.3b, January 1998
 *
 * Command interpreter
 * ------------------------------------------------------------------------*/

#include "prelude.h"
#include "storage.h"
#include "command.h"
#include "connect.h"
#include "errors.h"
#include <setjmp.h>
#include <ctype.h>

/* --------------------------------------------------------------------------
 * Local function prototypes:
 * ------------------------------------------------------------------------*/

static Void   local initialize	      Args((Int,String []));
static Void   local interpreter       Args((Int,String []));
static Void   local menu	      Args((Void));
static Void   local guidance	      Args((Void));
static Void   local forHelp	      Args((Void));
static Void   local set		      Args((Void));
static Void   local changeDir	      Args((Void));
static Void   local load	      Args((Void));
static Void   local project           Args((Void));
static Void   local readScripts       Args((Int));
static Void   local whatFiles	      Args((Void));
static Void   local editor	      Args((Void));
static Void   local find	      Args((Void));
static Void   local runEditor         Args((Void));
static Void   local evaluator	      Args((Void));
static Void   local stopAnyPrinting   Args((Void));
static Void   local showtype	      Args((Void));
static Void   local info	      Args((Void));
static Void   local showInst	      Args((Inst));
static Void   local describe	      Args((Text));
static Void   local listNames	      Args((Void));

static Void   local toggleSet	      Args((Char,Bool));
static Void   local togglesIn	      Args((Bool));
static Void   local optionInfo	      Args((Void));
static Bool   local processOption     Args((String));
static Int    local argToInt	      Args((String));

static Void   local loadProject       Args((String));
static Void   local clearProject      Args((Void));
static Void   local addScriptName     Args((String,Bool));
static Bool   local addScript	      Args((String,Long));
static Void   local forgetScriptsFrom Args((Module));
static Void   local setLastEdit       Args((String,Int));
static Void   local failed	      Args((Void));
static String local strCopy	      Args((String));

/* --------------------------------------------------------------------------
 * Machine dependent code for Hugs interpreter:
 * ------------------------------------------------------------------------*/

#include "machdep.c"
#ifdef WANT_TIMER
#include "timer.c"
#endif

/* --------------------------------------------------------------------------
 * Local data areas:
 * ------------------------------------------------------------------------*/

static Bool   printing	   = FALSE; 	/* TRUE => currently printing value*/
static Bool   showStats	   = FALSE; 	/* TRUE => print stats after eval  */
static Bool   listFiles	   = TRUE;  	/* TRUE => list files after loading*/
static Bool   addType	   = FALSE; 	/* TRUE => print type with value   */
static Bool   useShow	   = TRUE;  	/* TRUE => use Text/show printer   */
static Bool   chaseImports = TRUE;	/* TRUE => chase imports on load   */
static Bool   useDots      = RISCOS;	/* TRUE => use dots in progress    */

static String scriptName[NUM_SCRIPTS];	/* Script file names		   */
static Time   lastChange[NUM_SCRIPTS];	/* Time of last change to file	   */
static Bool   postponed[NUM_SCRIPTS];   /* Indicates postponed load	   */
/* static */  Int    numScripts;	/* Number of scripts loaded	   */
static Int    namesUpto;		/* Number of script names set	   */
static Bool   needsImports;		/* set to TRUE if imports required */
static String scriptFile;		/* Name of current script (if any) */

static String currProject = 0;		/* Name of current project file	   */
static Bool   projectLoaded = FALSE;	/* TRUE => project file loaded	   */

static String lastEdit	 = 0;		/* Name of file to edit (if any)   */
static Int    lastLine	 = 0;		/* Editor line number (if possible)*/
static String prompt     = 0;		/* Prompt string		   */

String hugsEdit = 0;			/* String for editor command       */
String hugsPath = 0;			/* String for file search path     */

/* --------------------------------------------------------------------------
 * Hugs entry point:
 * ------------------------------------------------------------------------*/

#ifndef NO_MAIN /* we omit main when building rohugs */

Main main Args((Int, String []));	/* now every func has a prototype  */

Main main(argc,argv)
int  argc;
char *argv[]; {
    gArgc = argc;
    gArgv = argv;
    CStackBase = &argc;                 /* Save stack base for use in gc   */

    /* The startup banner now includes my name.  Hugs is provided free of  */
    /* charge.  I ask however that you show your appreciation for the many */
    /* hours of work involved by retaining my name in the banner.  Thanks! */

    printf(" __ , ___    ___   ___    ___   __________   __________\n");
    printf("/_/  /  /   /  /  /  /   /  /  /  _______/  /  _______/   The O'Haskell User's\n");
    printf("    /  /___/  /  /  /   /  /  /  / _____   /  /______         Gofer System\n");
    printf("   /  ____   /  /  /   /  /  /  / /_   /  /______   /\n");
    printf("  /  /   /  /  /  /___/  /  /  /___/  /  _______/  /          Version 0.5\n");
    printf(" /__/   /__/  /_________/  /_________/  /_________/            Jan 2001\n\n");
    printf("                 Copyright (c) Mark P Jones, Johan Nordlander,\n");
    printf("                       Bj"OE"rn von Sydow, Magnus Carlsson,\n");
    printf("   Oregon Graduate Institute, Chalmers University of Technology, 1994-2001.\n\n");
    fflush(stdout);
    interpreter(argc,argv);
    printf("[Leaving O'Hugs]\n");
    everybody(EXIT);
    exit(0);
    MainDone
}

#endif

/* --------------------------------------------------------------------------
 * Initialization, interpret command line args and read prelude:
 * ------------------------------------------------------------------------*/

static Void local initialize(argc,argv)/* Interpreter initialization	   */
Int    argc;
String argv[]; {
    Module i;
    String proj = 0;

    setLastEdit((String)0,0);
    lastEdit	  = 0;
    scriptFile	  = 0;
    numScripts	  = 0;
    namesUpto	  = 1;
#if MACWP
    hugsPath      = strCopy("{OHUGS}lib;{OHUGS}libhugs");
    prompt	  = strCopy("? ");
    repeatStr	  = strCopy("$$");
#else    
#if !MSWIN
    hugsPath      = strCopy(fromEnv("OHUGSPATH",NULL));
    hugsEdit      = strCopy(fromEnv("OHUGSEDIT",fromEnv("EDITOR",NULL)));
    prompt	  = strCopy("? ");
    repeatStr	  = strCopy("$$");
#endif
#endif

    for (i=1; i<argc; ++i)		/* process command line arguments  */
	if (strcmp(argv[i],"+")==0 && i+1<argc)
	    if (proj) {
		ERRMSG(0) "Multiple project filenames on command line"
		EEND;
	    }
	    else
		proj = argv[++i];
	else if (!processOption(argv[i]))
	    addScriptName(argv[i],TRUE);

    scriptName[0] = strCopy(findPathname(NULL,STD_PRELUDE));

    everybody(INSTALL);
    if (proj) {
	if (namesUpto>1)
	    fprintf(stderr,
		    "\nUsing project file, ignoring additional filenames\n");
	loadProject(strCopy(proj));
    }
    readScripts(0);
}

/* --------------------------------------------------------------------------
 * Command line options:
 * ------------------------------------------------------------------------*/

struct options {			/* command line option toggles	   */
    char   c;				/* table defined in main app.	   */
    String description;
    Bool   *flag;
};
extern struct options toggle[];

static Void local toggleSet(c,state)	/* Set command line toggle	   */
Char c;
Bool state; {
    Int i;
    for (i=0; toggle[i].c; ++i)
	if (toggle[i].c == c) {
	    *toggle[i].flag = state;
	    return;
	}
    ERRMSG(0) "Unknown toggle `%c'", c
    EEND;
}

static Void local togglesIn(state)	/* Print current list of toggles in*/
Bool state; {				/* given state			   */
    Int count = 0;
    Int i;
    for (i=0; toggle[i].c; ++i)
	if (*toggle[i].flag == state) {
	    if (count==0)
		putchar(state ? '+' : '-');
	    putchar(toggle[i].c);
	    count++;
	}
    if (count>0)
	putchar(' ');
}

static Void local optionInfo() {	/* Print information about command */
    static String fmts = "%-5s%s\n";	/* line settings		   */
    static String fmtc = "%-5c%s\n";
    Int    i;

    printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
    for (i=0; toggle[i].c; ++i)
	printf(fmtc,toggle[i].c,toggle[i].description);

    printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
    printf(fmts,"hnum","Set heap size (cannot be changed within O'Hugs)");
    printf(fmts,"pstr","Set prompt string to str");
    printf(fmts,"rstr","Set repeat last expression string to str");
    printf(fmts,"Pstr","Set search path for script files to str");
    printf(fmts,"Estr","Use editor setting given by str");

    printf("\nCurrent settings: ");
    togglesIn(TRUE);
    togglesIn(FALSE);
    printf("-h%d",heapSize);
    printf(" -p");
    printString(prompt);
    printf(" -r");
    printString(repeatStr);
    printf("\nSearch path     : -P");
    printString(hugsPath);
    printf("\nEditor setting  : -E");
    printString(hugsEdit);
    putchar('\n');
}

static Bool local processOption(s)	/* process string s for options,   */
String s; {				/* return FALSE if none found.	   */
    Bool state;

    if (s[0]=='-')
	state = FALSE;
    else if (s[0]=='+')
	state = TRUE;
    else
	return FALSE;

    while (*++s)
	switch (*s) {
	    case 'p' : if (s[1]) {
			   if (prompt) free(prompt);
			   prompt = strCopy(s+1);
		       }
		       return TRUE;

	    case 'r' : if (s[1]) {
			   if (repeatStr) free(repeatStr);
			   repeatStr = strCopy(s+1);
		       }
		       return TRUE;

	    case 'P' : if (hugsPath) free(hugsPath);
		       hugsPath = strCopy(s+1);
		       return TRUE;

	    case 'E' : if (hugsEdit) free(hugsEdit);
		       hugsEdit = strCopy(s+1);
		       return TRUE;

	    case 'h' : if (heapBuilt()) {
			   ERRMSG(0) "Cannot change heap size"
			   EEND;
		       }
		       heapSize = argToInt(s);
		       if (heapSize<MINIMUMHEAP)
			   heapSize = MINIMUMHEAP;
		       else if (MAXIMUMHEAP && heapSize>MAXIMUMHEAP)
			   heapSize = MAXIMUMHEAP;
		       return TRUE;

	    default  : toggleSet(*s,state);
		       break;
	}
    return TRUE;
}

static Int local argToInt(s)		/* read integer from argument str  */
String s; {
    Int    n = 0;
    String t = s++;

    if (*s=='\0' || !isascii(*s) || !isdigit(*s)) {
	ERRMSG(0) "Missing integer in option setting \"%s\"", t
	EEND;
    }

    do {
	Int d = (*s++) - '0';
	if (n > ((MAXPOSINT - d)/10)) {
	    ERRMSG(0) "Option setting \"%s\" is too large", t
	    EEND;
	}
	n     = 10*n + d;
    } while (isascii(*s) && isdigit(*s));

    if (*s=='K' || *s=='k') {
	if (n > (MAXPOSINT/1000)) {
	    ERRMSG(0) "Option setting \"%s\" is too large", t
	    EEND;
	}
	n *= 1000;
	s++;
    }

    if (*s!='\0') {
	ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
	EEND;
    }

    return n;
}

/* --------------------------------------------------------------------------
 * Print Menu of list of commands:
 * ------------------------------------------------------------------------*/

static struct cmd cmds[] = {
 {":?",	     HELP},   {":cd",   CHGDIR},  {":also",    ALSO},
 {":type",   TYPEOF}, {":!",    SYSTEM},  {":load",    LOAD},
 {":reload", RELOAD}, {":gc",   COLLECT}, {":edit",    EDIT},
 {":quit",   QUIT},   {":set",  SET},     {":find",    FIND},
 {":names",  NAMES},  {":info",	INFO},	  {":project", PROJECT},
 {"",        EVAL},
 {0,0}
};

static Void local menu() {
    printf("LIST OF COMMANDS:  Any command may be abbreviated to :c where\n");
    printf("c is the first character in the full name.\n\n");
    printf(":load <filenames>   load scripts from specified files\n");
    printf(":load               clear all files except prelude\n");
    printf(":also <filenames>   read additional script files\n");
    printf(":reload             repeat last load command\n");
    printf(":project <filename> use project file\n");
    printf(":edit <filename>    edit file\n");
    printf(":edit               edit last file\n");
    printf("<expr>              evaluate expression\n");
    printf(":type <expr>        print type of expression\n");
    printf(":?                  display this list of commands\n");
    printf(":set <options>      set command line options\n");
    printf(":set                help on command line options\n");
    printf(":names [pat]        list names currently in scope\n");
    printf(":info <names>       describe named objects\n");
    printf(":find <name>        edit file containing definition of name\n");
    printf(":!command           shell escape\n");
    printf(":cd dir             change directory\n");
    printf(":gc                 force garbage collection\n");
    printf(":quit               exit O'Hugs interpreter\n");
}

static Void local guidance() {
    printf("Command not recognised.  ");
    forHelp();
}

static Void local forHelp() {
    printf("Type :? for help\n");
}

/* --------------------------------------------------------------------------
 * Setting of command line options:
 * ------------------------------------------------------------------------*/

struct options toggle[] = {		/* List of command line toggles	   */
    {'s', "Print no. reductions/cells after eval", &showStats},
    {'t', "Print type after evaluation",	   &addType},
    {'f', "Terminate evaluation on first error",   &failOnError},
    {'g', "Print no. cells recovered after gc",	   &gcMessages},
    {'l', "Literate scripts as default",	   &literateScripts},
    {'e', "Warn about errors in literate scripts", &literateErrors},
    {'.', "Print dots to show progress",	   &useDots},
    {'w', "Always show which files loaded",	   &listFiles},
    {'k', "Show kind errors in full",		   &kindExpert},
    {'u', "Use \"show\" to display results",	   &useShow},
    {'i', "Chase imports while loading files",	   &chaseImports},
    {0,   0,					   0}
};

static Void local set() {		/* change command line options from*/
    String s;				/* Hugs command line		   */

    if (s=readFilename()) {
	do {
	    if (!processOption(s)) {
		ERRMSG(0) "Option string must begin with `+' or `-'"
		EEND;
	    }
	} while (s=readFilename());
    }
    else
	optionInfo();
}

/* --------------------------------------------------------------------------
 * Change directory command:
 * ------------------------------------------------------------------------*/

static Void local changeDir() {		/* change directory		   */
    String s = readFilename();
    if (s && chdir(s)) {
	ERRMSG(0) "Unable to change to directory \"%s\"", s
	EEND;
    }
}

/* --------------------------------------------------------------------------
 * Loading project and script files:
 * ------------------------------------------------------------------------*/

static Void local loadProject(s)	/* Load project file		  */
String s; {
    clearProject();
    currProject = s;
    projInput(currProject);
    scriptFile = currProject;
    forgetScriptsFrom(1);
    while (s=readFilename())
	addScriptName(s,TRUE);
    if (namesUpto<=1) {
	ERRMSG(0) "Empty project file"
	EEND;
    }
    scriptFile    = 0;
    projectLoaded = TRUE;
}

static Void local clearProject() {     /* clear name for current project   */
    if (currProject)
	free(currProject);
    currProject   = 0;
    projectLoaded = FALSE;
#if MSWIN
    setLastEdit((String)0,0);
#endif
}

static Void local addScriptName(s,sch)	/* Add script to list of files	   */
String s;				/* to be read in ...		   */
Bool   sch; {				/* TRUE => requires pathname search*/
    if (namesUpto>=NUM_SCRIPTS) {
	ERRMSG(0) "Too many script files (maximum of %d allowed)",
		  NUM_SCRIPTS
	EEND;
    }
    else
	scriptName[namesUpto++] = strCopy(sch ? findPathname(NULL,s) : s);
}

static Bool local addScript(fname,len) /* read single script file	   */
String fname;			       /* name of script file		   */
Long   len; {			       /* length of script file 	   */
    scriptFile = fname;

#if MSWIN			       /* Set clock cursor while loading   */
    allowBreak();
    SetCursor(LoadCursor(NULL, IDC_WAIT));
#endif
#ifndef NO_MAIN
    printf("Reading script file \"%s\":\n",fname);
#endif
    setLastEdit(fname,0);

    needsImports = FALSE;
    parseScript(fname,len);	       /* process script file		   */
    if (needsImports)
	return FALSE;
    checkDefns();
    typeCheckDefns();
    compileDefns();
    scriptFile = 0;
    return TRUE;
}

Bool chase(imps)			/* Process list of import requests */
List imps; {
    if (chaseImports) {
	Int    origPos  = numScripts;	/* keep track of original position */
	String origName = scriptName[origPos];
	for (; nonNull(imps); imps=tl(imps)) {
	    String iname = findPathname(origName,textToStr(textOf(hd(imps))));
	    Int    i     = 0;
	    for (; i<namesUpto; i++)
		if (strcmp(scriptName[i],iname)==0)
		    break;
	    if (i>=origPos) {		/* Neither loaded or queued	   */
		String theName;
		Time   theTime;
		Bool   thePost;

		postponed[origPos] = TRUE;
		needsImports       = TRUE;

		if (i>=namesUpto)	/* Name not found (i==namesUpto)   */
		    addScriptName(iname,FALSE);
		else if (postponed[i]) {/* Check for recursive dependency  */
		    ERRMSG(0)
		      "Recursive import dependency between \"%s\" and \"%s\"",
		      scriptName[origPos], iname
		    EEND;
		}
		/* Right rotate section of tables between numScripts and i so
		 * that i ends up with other imports in front of orig. script
		 */
		theName = scriptName[i];
		thePost = postponed[i];
		timeSet(theTime,lastChange[i]);
		for (; i>numScripts; i--) {
		    scriptName[i] = scriptName[i-1];
		    postponed[i]  = postponed[i-1];
		    timeSet(lastChange[i],lastChange[i-1]);
		}
		scriptName[numScripts] = theName;
		postponed[numScripts]  = thePost;
		timeSet(lastChange[numScripts],theTime);
		origPos++;
	    }
	}
	return needsImports;
    }
    return FALSE;
}

static Void local forgetScriptsFrom(scno)/* remove scripts from system	   */
Module scno; {
    Module i;
    for (i=scno; i<namesUpto; ++i)
	if (scriptName[i])
	    free(scriptName[i]);
    dropModulesFrom(scno-1);		 /* don't count prelude as module  */
    namesUpto = scno;
    if (numScripts>namesUpto)
	numScripts = scno;
}

/* --------------------------------------------------------------------------
 * Commands for loading and removing script files:
 * ------------------------------------------------------------------------*/

static Void local load() {	       /* read filenames from command line */
    String s;			       /* and add to list of files waiting */
				       /* to be read			   */
    while (s=readFilename())
	addScriptName(s,TRUE);
    readScripts(1);
}

static Void local project() {	       /* read list of file names from     */
    String s;			       /* project file			   */

    if ((s=readFilename()) || currProject) {
	if (!s)
	    s = strCopy(currProject);
	else if (readFilename()) {
	    ERRMSG(0) "Too many project files"
	    EEND;
	}
	else
	    s = strCopy(s);
    }
    else {
	ERRMSG(0) "No project filename specified"
	EEND;
    }
    loadProject(s);
    readScripts(1);
}

static Void local readScripts(n)	/* Reread current list of scripts, */
Int n; {				/* loading everything after and	   */
    Time timeStamp;			/* including the first script which*/
    Long fileSize;			/* has been either changed or added*/

#if MSWIN
    SetCursor(LoadCursor(NULL, IDC_WAIT));
#endif

    for (; n<numScripts; n++) {		/* Scan previously loaded scripts  */
	getFileInfo(scriptName[n], &timeStamp, &fileSize);
	if (timeChanged(timeStamp,lastChange[n])) {
	    dropModulesFrom(n-1);
	    numScripts = n;
	    break;
	}
    }
    for (; n<NUM_SCRIPTS; n++)		/* No files have been postponed at */
	postponed[n] = FALSE;		/* this stage			   */

    while (numScripts<namesUpto) {	/* Process any remaining scripts   */
	getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
	timeSet(lastChange[numScripts],timeStamp);
	if (numScripts>0)		/* no new module for prelude	   */
	    startNewModule();
	if (addScript(scriptName[numScripts],fileSize))
	    numScripts++;
	else
	    dropModulesFrom(numScripts-1);
    }

    if (listFiles)
	whatFiles();
    if (numScripts<=1)
	setLastEdit((String)0, 0);
}

static Void local whatFiles() {		/* list files in current session   */
    int i;
    printf("\nO'Hugs session for:");
    if (projectLoaded)
	printf(" (project: %s)",currProject);
    for (i=0; i<numScripts; ++i)
	printf("\n%s",scriptName[i]);
    putchar('\n');
}

/* --------------------------------------------------------------------------
 * Access to external editor:
 * ------------------------------------------------------------------------*/

static Void local editor() {		/* interpreter-editor interface	   */
    String newFile  = readFilename();
    if (newFile) {
	setLastEdit(newFile,0);
	if (readFilename()) {
	    ERRMSG(0) "Multiple filenames not permitted"
	    EEND;
	}
    }
    runEditor();
}

static Void local find() {		/* edit file containing definition */
    String nm = readFilename();		/* of specified name		   */
    if (!nm) {
	ERRMSG(0) "No name specified"
	EEND;
    }
    else if (readFilename()) {
	ERRMSG(0) "Multiple names not permitted"
	EEND;
    }
    else {
	Text t;
	Cell c;
	startNewModule();
	if (nonNull(c=findTycon(t=findText(nm))))
	    setLastEdit(scriptName[moduleThisTycon(c)],tycon(c).line);
	else if (nonNull(c=findName(t)))
	    setLastEdit(scriptName[moduleThisName(c)],name(c).line);
	else {
	    ERRMSG(0) "No current definition for name \"%s\"", nm
	    EEND;
	}
	runEditor();
    }
}

static Void local runEditor() {		/* run editor on file lastEdit at  */
    if (startEdit(lastLine,lastEdit))	/* line lastLine		   */
	readScripts(1);
}

static Void local setLastEdit(fname,line)/* keep name of last file to edit */
String fname;
Int    line; {
    if (lastEdit)
	free(lastEdit);
    lastEdit = strCopy(fname);
    lastLine = line;
#if MSWIN
    DrawStatusLine(hWndMain);		/* Redo status line		   */
#endif
}

/* --------------------------------------------------------------------------
 * Read and evaluate an expression:
 * ------------------------------------------------------------------------*/

static Void local evaluator() {        /* evaluate expr and print value    */
    Type type, mt;

    scriptFile = 0;
    startNewModule();		       /* Enables recovery of storage	   */
				       /* allocated during evaluation	   */
    parseExp();
    checkExp();
    defaultDefns = evalDefaults;
    type         = typeCheckExp(TRUE);
    mt           = isPolyType(type) ? monoTypeOf(type) : type;
    if (whatIs(mt)==QUAL) {
	ERRMSG(0) "Unresolved overloading" ETHEN
	ERRTEXT   "\n*** type       : "    ETHEN ERRTYPE(type);
	ERRTEXT   "\n*** expression : "    ETHEN ERREXPR(inputExpr);
	ERRTEXT   "\n"
	EEND;
    }
  
#if PROFILING
    profilerLog("profile.hp");
    numReductions = 0;
    garbageCollect();
#endif

    evalExp();
    consGC = FALSE;

#ifdef WANT_TIMER
    updateTimers();
#endif
#if IO_MONAD
    if (typeMatches(type,typeProgIO)) {
	ioExecute();
    }
    else
#endif
    {
#if OBJ
        if (!tryOExecute(type))
#endif
        {   Cell printer = namePrint;
            if (useShow) {
	        Cell d = getDictFor(classShow,type);
	        if (isNull(d)) {
		    printing = FALSE;
		    ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
		    ERRTEXT   "\n*** expression : "   ETHEN ERREXPR(inputExpr);
		    ERRTEXT   "\n*** of type    : "   ETHEN ERRTYPE(type);
		    ERRTEXT   "\n"
		    EEND;
	        }
	        printer = dictGet(d,mfunOf(nameShowsPrec));
	    }
          
            top()  = ap(ap(ap(printer,mkInt(MIN_PREC)),top()),nameNil);
            if (addType) {
	        onto(NIL);
	        pushed(0) = pushed(1);
	        pushed(1) = type;
	        outputString(stdout);
	        printf(" :: ");
	        printType(stdout,pop());
            } else
	        outputString(stdout);
        }
    }
    stopAnyPrinting();
}

Void evalExp() {		/* Compile expression and prepare  */
    compileExp();			/* for execution		   */
    clearStack();
    graphForExp();
    numCells	  = 0;
    numReductions = 0;
    numberGcs     = 0;
    printing      = TRUE;
}

static Void local stopAnyPrinting() {  /* terminate printing of expression,*/
    if (printing) {		       /* after successful termination or  */
	printing = FALSE;	       /* runtime error (e.g. interrupt)   */
	putchar('\n');
	if (showStats) {
#define plural(v)   v, (v==1?"":"s")
	    printf("(%lu reduction%s, ",plural(numReductions));
	    printf("%lu cell%s",plural(numCells));
	    if (numberGcs>0)
		printf(", %u garbage collection%s",plural(numberGcs));
	    printf(")\n");
#undef plural
	}
	fflush(stdout);
    }
}

/* --------------------------------------------------------------------------
 * Print type of input expression:
 * ------------------------------------------------------------------------*/

static Void local showtype() {	       /* print type of expression (if any)*/
    Cell type;

    startNewModule();		       /* Enables recovery of storage	   */
				       /* allocated during evaluation	   */
    parseExp();
    checkExp();
    defaultDefns = evalDefaults;
    type = typeCheckExp(FALSE);
    printExp(stdout,inputExpr);
    printf(" :: ");
    printType(stdout,type);
    putchar('\n');
}

/* --------------------------------------------------------------------------
 * Enhanced help system:  print current list of scripts or give information
 * about an object.
 * ------------------------------------------------------------------------*/

static Void local info() {		/* describe objects		   */
    Int    count = 0;			/* or give menu of commands	   */
    String s;

    startNewModule();			/* for recovery of storage	   */
    for (; s=readFilename(); count++)
	describe(findText(s));
    if (count == 0)
	whatFiles();
}

static Void local describe(t)		/* describe an object		   */
Text t; {
    Tycon tc = findTycon(t);
    Class cl = findClass(t);
    Name  nm = findName(t);

    if (nonNull(tc)) {			/* as a type constructor	   */
	Type t = satTycon(tc);
	Inst in;
	
	printf("-- type constructor");
	if (kindExpert) {
	    printf(" (kind ");
	    printKind(stdout,tycon(tc).kind);
	    putchar(')');
	}
	if (nonNull(tycon(tc).variance)) {
	    printf(" (variance ");
	    printVariance(stdout,tycon(tc).variance);
	    putchar(')');
	}
	putchar('\n');
	switch (tycon(tc).what) {
	    case SYNONYM      : printf("type ");
				printType(stdout,t);
				printf(" = ");
				printType(stdout,tycon(tc).defn);
				break;

	    case STRUCTTYPE   :
	    case NEWTYPE      :
	    case DATATYPE     : {   List cs;
	    			    List axs = tycon(tc).axioms;
				    if (tycon(tc).what==DATATYPE)
					printf("data ");
				    else if (tycon(tc).what==STRUCTTYPE)
				        printf("struct ");
				    else
					printf("newtype ");
				    printType(stdout,t);
				    printAxioms(stdout,tc);

				    if (tycon(tc).what==STRUCTTYPE)
				        printf("\n\n-- selectors:");
				    else
					printf("\n\n-- constructors:");
				    for (; nonNull(axs); axs=tl(axs)) {
				        Tycon h = getHead(monoType(hd(axs)));
				        for (cs=tycon(h).defn; nonNull(cs); cs=tl(cs)) {
					    putchar('\n');
					    printExp(stdout,hd(cs));
					    printf(" :: ");
					    printType(stdout,liftedType(hd(cs),tc));
					}
				    }
				    for (cs=tycon(tc).defn; nonNull(cs); cs=tl(cs)) {
					putchar('\n');
					printExp(stdout,hd(cs));
					printf(" :: ");
					printType(stdout,name(hd(cs)).type);
				    }
				}
				break;

	    case PRIMTYPE     : printf("type ");
				printType(stdout,t);
				printAxioms(stdout,tc);
				printf("   -- primitive");
				break;
	    case RESTRICTSYN  : printf("type ");
				printType(stdout,t);
				printf(" = <restricted>");
				break;
	}
	putchar('\n');
	if (nonNull(in=findFirstInst(tc))) {
	    printf("\n-- instances:\n");
	    do {
		showInst(in);
		in = findNextInst(tc,in);
	    } while (nonNull(in));
	}
	putchar('\n');
    }

    if (nonNull(cl)) {			/* as a class			   */
	List ins = cclass(cl).instances;
	if (cclass(cl).sig==STAR)
	    printf("-- type class");
	else {
	    printf("-- constructor class");
	    if (kindExpert) {
		printf(" with instances of kind ");
		printKind(stdout,cclass(cl).sig);
	    }
	}
	printf("\nclass ");
	if (nonNull(cclass(cl).supers)) {
	    List cs = cclass(cl).supers;
	    if (nonNull(tl(cs))) {
		putchar('(');
		for (;;) {
		    printf("%s a",textToStr(cclass(hd(cs)).text));
		    if (nonNull(cs=tl(cs)))
			printf(", ");
		    else
			break;
		}
		putchar(')');
	    }
	    else
		printf("%s a",textToStr(cclass(hd(cs)).text));

	    printf(" => ");
	}
	printf("%s a",textToStr(cclass(cl).text));
	if (nonNull(cclass(cl).members)) {
	    List ms = cclass(cl).members;
	    printf(" where");
	    do {
		Type t = monoTypeOf(name(hd(ms)).type);
		printf("\n  ");
		printExp(stdout,hd(ms));
		printf(" :: ");
		if (isNull(tl(fst(snd(t)))))
		    t = snd(snd(t));
		else
		    t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
		printType(stdout,t);
		ms = tl(ms);
	    } while (nonNull(ms));
	}
	putchar('\n');
	if (nonNull(ins)) {
	    printf("\n-- instances:\n");
	    do {
		showInst(hd(ins));
		ins = tl(ins);
	    } while (nonNull(ins));
	}
	putchar('\n');
    }

    if (nonNull(nm)) {			/* as a function/name		   */
	printExp(stdout,nm);
	printf(" :: ");
	if (nonNull(name(nm).type)) {	/* we have to run the type checker */
	    inputExpr = nm;		/* to convert GTC type to HTC form */
	    printType(stdout,typeCheckExp(FALSE));
	}
	else
	    printf("<unknown type>");

	if (isCfun(nm) && isStructSel(nm))
	    printf("  -- struct selector");
	else

	if (isCfun(nm))
	    printf("  -- data constructor");
	else if (isMfun(nm))
	    printf("  -- class member");

	if (name(nm).primDef)
	    printf("   -- primitive");
	printf("\n\n");
    }
    if (isalpha(textToStr(t)[0]) && nonNull(findName(mkStructSel(t))))
        describe(mkStructSel(t));
    else if (isNull(tc) && isNull(cl) && isNull(nm)) {
	printf("Unknown reference `%s'\n",textToStr(t));
    }
}

static Void local showInst(in)		/* Display instance decl header	   */
Inst in; {
    printf("instance ");
    if (nonNull(inst(in).specifics)) {
	printContext(stdout,inst(in).specifics);
	printf(" => ");
    }
    printPred(stdout,makeInstPred(in));
    putchar('\n');
}

/* --------------------------------------------------------------------------
 * List all names currently in scope:
 * ------------------------------------------------------------------------*/

static Void local listNames() {		/* list names matching optional pat*/
    String pat   = readFilename();
    List   names = NIL;
    Int    width = getTerminalWidth() - 1;
    Int    count = 0;
    Int    termPos;

    if (pat)				/* First gather names to list	   */
	do
	    names = addNamesMatching(pat,names);
	while (pat=readFilename());
    else
	names = addNamesMatching((String)0,names);

    if (isNull(names)) {		/* Then print them out		   */
	ERRMSG(0) "No names selected"
	EEND;
    }
    for (termPos=0; nonNull(names); names=tl(names)) {
	String s = textToStr(name(hd(names)).text);
	Int    l = strlen(s);
	if (termPos+1+l>width) {
	    putchar('\n');
	    termPos = 0;
	}
	else if (termPos>0) {
	    putchar(' ');
	    termPos++;
	}
	printf("%s",s);
	termPos += l;
	count++;
    }
    printf("\n(%d names listed)\n", count);
}

/* --------------------------------------------------------------------------
 * main read-eval-print loop, with error trapping:
 * ------------------------------------------------------------------------*/

static jmp_buf catch_error;	       /* jump buffer for error trapping   */

static Void local interpreter(argc,argv)/* main interpreter loop	   */
Int    argc;
String argv[]; {
    Int errorNumber = setjmp(catch_error);

    breakOn(TRUE);		       /* enable break trapping 	   */
    if (numScripts==0) {	       /* only succeeds on first time,	   */
	if (errorNumber)	       /* before prelude has been loaded   */
	    fatal("Unable to load prelude");
	initialize(argc,argv);
	forHelp();
    }

    for (;;) {
	Command cmd;
	everybody(RESET);		/* reset to sensible initial state */
	dropModulesFrom(numScripts-1);	/* remove partially loaded scripts */
					/* not counting prelude as a module*/
	consoleInput(prompt);
	cmd = readCommand(cmds, (Char)':', (Char)'!');
#ifdef WANT_TIMER
	updateTimers();
#endif
	switch (cmd) {
	    case EDIT	: editor();
			  break;
	    case FIND   : find();
			  break;
	    case LOAD	: clearProject();
			  forgetScriptsFrom(1);
			  load();
			  break;
	    case ALSO   : clearProject();
			  forgetScriptsFrom(numScripts);
			  load();
			  break;
	    case RELOAD : readScripts(1);
			  break;
	    case PROJECT: project();
			  break;
	    case EVAL	: evaluator();
			  break;
	    case TYPEOF : showtype();
			  break;
	    case NAMES  : listNames();
			  break;
	    case HELP	: menu();
			  break;
	    case BADCMD : guidance();
			  break;
	    case SET    : set();
			  break;
	    case SYSTEM : shellEsc(readLine());
			  break;
	    case CHGDIR : changeDir();
			  break;
	    case INFO   : info();
			  break;
	    case QUIT	: return;
	    case COLLECT: consGC = FALSE;
			  garbageCollect();
			  consGC = TRUE;
			  printf("Garbage collection recovered %d cells\n",
				 cellsRecovered);
			  break;
	    case NOCMD	: break;
	}
#ifdef WANT_TIMER
	updateTimers();
	printf("Elapsed time (ms): %ld (user), %ld (system)\n",
	       millisecs(userElapsed), millisecs(systElapsed));
#endif
    }
}

/* --------------------------------------------------------------------------
 * Display progress towards goal:
 * ------------------------------------------------------------------------*/

static Target currTarget;
static Bool   aiming = FALSE;
static Int    currPos;
static Int    maxPos;
static Int    charCount;

Void setGoal(what, t)		       /* Set goal for what to be t	   */
String what;
Target t; {
#ifdef NO_MAIN
    return;
#endif
    currTarget = (t?t:1);
    aiming     = TRUE;
    if (useDots) {
	currPos = strlen(what);
	maxPos  = getTerminalWidth() - 1;
	printf("%s",what);
    }
    else
	for (charCount=0; *what; charCount++)
	    putchar(*what++);
    fflush(stdout);
}

Void soFar(t)			       /* Indicate progress towards goal   */
Target t; {			       /* has now reached t		   */
#ifdef NO_MAIN
    return;
#endif
    if (useDots) {
	Int newPos = (Int)((maxPos * ((long)t))/currTarget);

	if (newPos>maxPos)
	    newPos = maxPos;

	if (newPos>currPos) {
	    do
		putchar('.');
	    while (newPos>++currPos);
	    fflush(stdout);
	}
	fflush(stdout);
    }
}

Void done() {			       /* Goal has now been achieved	   */
#ifdef NO_MAIN
    return;
#endif
    if (useDots) {
	while (maxPos>currPos++)
	    putchar('.');
	putchar('\n');
	aiming = FALSE;
    }
    else
	for (; charCount>0; charCount--) {
	    putchar('\b');
	    putchar(' ');
	    putchar('\b');
	}
    fflush(stdout);
}

static Void local failed() {	       /* Goal cannot be reached due to    */
    if (aiming) {		       /* errors			   */
	aiming = FALSE;
	putchar('\n');
	fflush(stdout);
    }
}

/* --------------------------------------------------------------------------
 * Error handling:
 * ------------------------------------------------------------------------*/

Void errHead(l) 		       /* print start of error message	   */
Int l; {
    failed();			       /* failed to reach target ...	   */
    stopAnyPrinting();
    fprintf(errorStream,"ERROR");

    if (scriptFile) {
	fprintf(errorStream," \"%s\"", scriptFile);
	setLastEdit(scriptFile,l);
	if (l) fprintf(errorStream," (line %d)",l);
	scriptFile = 0;
    }
    fprintf(errorStream,": ");
    fflush(errorStream);
}

Void errFail() {			/* terminate error message and	   */
    putc('\n',errorStream);		/* produce exception to return to  */
    fflush(errorStream);		/* main command loop		   */
    longjmp(catch_error,1);
}

Void errAbort() {			/* altern. form of error handling  */
    failed();				/* used when suitable error message*/
    stopAnyPrinting();			/* has already been printed	   */
    errFail();
}

Void internal(msg)			/* handle internal error 	   */
String msg; {
#if MSWIN
    char buf[300];
    wsprintf(buf,"INTERNAL ERROR: %s",msg);
    MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
#endif
    failed();
    stopAnyPrinting();
    fprintf(errorStream,"INTERNAL ERROR: %s\n",msg);
    fflush(errorStream);
    longjmp(catch_error,1);
}

Void fatal(msg)				/* handle fatal error		   */
String msg; {
#if MSWIN
    char buf[300];
    wsprintf(buf,"FATAL ERROR: %s",msg);
    MessageBox(hWndMain, buf, appName, MB_ICONHAND | MB_OK);
#endif
    fflush(stdout);
    printf("\nFATAL ERROR: %s\n",msg);
    everybody(EXIT);
    exit(1);
}

sigHandler(breakHandler) {		/* respond to break interrupt	   */
#ifdef NO_MAIN
    fprintf(stderr,"Interrupted!\n");
    doexit(1);
#endif
#if MSWIN
    MessageBox(GetFocus(), "Interrupted!", appName, MB_ICONSTOP | MB_OK);
#endif
    Hilite
    printf("{Interrupted!}\n");
    Lolite
    breakOn(TRUE);
    everybody(BREAK);
    failed();
    stopAnyPrinting();
    fflush(stdout);
    longjmp(catch_error,1);
    sigResume;/*NOTREACHED*/
}

/* --------------------------------------------------------------------------
 * Read value from environment variable:
 * ------------------------------------------------------------------------*/

String fromEnv(var,def)		/* return value of:	 		   */
String var;			/*     environment variable named by var   */
String def; {			/* or: default value given by def	   */
    String s = getenv(var);

    return (s ? s : def);
}

/* --------------------------------------------------------------------------
 * String manipulation routines:
 * ------------------------------------------------------------------------*/

static String local strCopy(s)	       /* make malloced copy of a string   */
String s; {
    if (s && *s) {
	char *t, *r;
	if ((t=(char *)malloc(strlen(s)+1))==0) {
	    ERRMSG(0) "String storage space exhausted"
	    EEND;
	}
	for (r=t; *r++ = *s++; )
	    ;
	return t;
    }
    return NULL;
}

/* --------------------------------------------------------------------------
 * Send message to each component of system:
 * ------------------------------------------------------------------------*/

Void everybody(what)		/* send command `what' to each component of*/
Int what; {			/* system to respond as appropriate ...    */
    machdep(what);		/* The order of calling each component is  */
    storage(what);		/* important for the INSTALL command	   */
    input(what);
    staticAnalysis(what);
    typeChecker(what);
    compiler(what);
    machine(what);
    builtIn(what);
}

/*-------------------------------------------------------------------------*/