/* -------------------------------------------------------------------------- * Implementation of the Hugs server API. * * The Hugs server allows you to programmatically load scripts and * build/evaluate terms. Used by 'runhugs' to provide a batch-mode * UI to the interpreter. * * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the * Yale Haskell Group, and the OGI School of Science & Engineering at OHSU, * 1994-2003, All rights reserved.  It is distributed as free software under * the license in the file "License", which is included in the distribution. * * $RCSfile: server.c,v $ * $Revision: 1.45 $ * $Date: 2005/09/10 09:42:26 $ * ------------------------------------------------------------------------*/#include "prelude.h"#include "storage.h"#include "connect.h"#include "script.h"#include "machdep.h"#include "evaluator.h"#include "opts.h"#include "strutil.h"#include "errors.h"#include "server.h" #include <setjmp.h> static Void   setHugsAPI   Args((Void));static Bool   SetModule    Args((String));#ifndef NO_DYNAMIC_TYPESstatic Bool   linkDynamic     Args((Void));#endif /* -------------------------------------------------------------------------- * Dynamic linking * * The simplest way to do dynamic linking is this: * 1) load the dll/shared object file * 2) get the address of an initialisation function *    from the dll symbol table * 3) call the initialisation function - which returns a "virtual *    function table" - a struct containing the addresses of all other *    functions and variables that we need to access. * ------------------------------------------------------------------------*/ static Int    GetNumScripts   Args((Void));static Void   Reset           Args((Int));static Void   SetOutputEnable Args((Bool));static Void   ChangeDir       Args((String));static Void   LoadProject     Args((String));static Void   LoadFile        Args((String));static Void   LoadStringF     Args((String));static Void   SetOptions      Args((String));static String GetOptions      Args((Void));static HVal   CompileExpr     Args((String, String));static Void   GarbageCollect  Args((void));static Void   LookupName      Args((String, String));static Void   MkInt           Args((Int));static Void   MkAddr          Args((void*));static Void   MkString        Args((String));static Void   Apply           Args((Void));static Int    EvalInt         Args((Void));static void*  EvalAddr        Args((void));static String EvalString      Args((Void));static Int    DoIO            Args((Void));static Int    DoIO_Int        Args((int*));static Int    DoIO_Addr       Args((void**));static HVal   PopHVal         Args((Void));static Void   PushHVal        Args((HVal));static Void   FreeHVal        Args((HVal)); static HugsServerAPI hugs;             /* virtual function table            */ static Void setHugsAPI() {       /* initialise virtual function table */    static Bool api_inited = FALSE;    if (!api_inited) {      api_inited = TRUE;       hugs.clearError      = ClearError;      hugs.setHugsArgs     = setHugsArgs;      hugs.getNumScripts   = GetNumScripts;      hugs.reset           = Reset;      hugs.setOutputEnable = SetOutputEnable;      hugs.changeDir       = ChangeDir;      hugs.loadProject     = LoadProject;      hugs.loadFile        = LoadFile;      hugs.loadFromBuffer  = LoadStringF;      hugs.setOptions      = SetOptions;      hugs.getOptions      = GetOptions;      hugs.compileExpr     = CompileExpr;      hugs.garbageCollect  = GarbageCollect;      hugs.lookupName      = LookupName;      hugs.mkInt           = MkInt;      hugs.mkAddr          = MkAddr;      hugs.mkString        = MkString;      hugs.apply           = Apply;      hugs.evalInt         = EvalInt;      hugs.evalAddr        = EvalAddr;      hugs.evalString      = EvalString;      hugs.doIO            = DoIO;      hugs.doIO_Int        = DoIO_Int;      hugs.doIO_Addr       = DoIO_Addr;      hugs.popHVal         = PopHVal;      hugs.pushHVal        = PushHVal;      hugs.freeHVal        = FreeHVal;    }} /* -------------------------------------------------------------------------- * Error handling * * We buffer error messages and refuse to execute commands until * the error is cleared. * ------------------------------------------------------------------------*/ #define ErrorBufferSize 10000 static char  serverErrMsg[ErrorBufferSize];   /* Buffer for error messages */char* lastError = NULL; String ClearError(){    String err = lastError;    lastError  = NULL;    ClearOutputBuffer();     if (err && (numLoadedScripts() > 0))     {        everybody(RESET);                dropScriptsFrom(numLoadedScripts()-1);  /* remove partially loaded scripts */    }    return err;} Void setError(s)            /* Format an error message        */String s; {    Int    n = 0;    String err = ClearOutputBuffer();     if (NULL == err) {	n = snprintf(serverErrMsg, ErrorBufferSize, "%s\n", s);    } else {	n = snprintf(serverErrMsg, ErrorBufferSize, "%s\n%s\n", s, err);    }    if (0 <= n && n <= ErrorBufferSize) {	lastError = serverErrMsg;    } else {	lastError = "error buffer overflowed\n";    }} /* All server entry points set CStackBase for the benefit of the (conservative) * GC and do error catching.  Any calls to Hugs functions should be "protected" * by being placed inside this macro. * *   void entryPoint(arg1, arg2, result) *   T1 arg1; *   T2 arg2; *   T3 *result; *   { *       protect(doNothing(), *           ... *       ); *   } * * Macro decomposed into BEGIN_PROTECT and END_PROTECT pieces so that i * can be used on some compilers (Mac?) that have limits on the size of * macro arguments. */#define BEGIN_PROTECT \  if (NULL == lastError) { \      Cell dummy; \      CStackBase = &dummy;              /* Save stack base for use in gc  */ \      consGC = TRUE;                    /* conservative GC is the default */ \      if (!setjmp(catch_error)) {#define END_PROTECT \      } else { \	setError("Error occurred"); \	normalTerminal(); \      }	\  }#define protect(s)	BEGIN_PROTECT s; END_PROTECT /* -------------------------------------------------------------------------- * Initialisation * ------------------------------------------------------------------------*/ /* I've added a special case for the server.  Probably should just add   another entry point but what the heck.  If argc = -1 then the hugs   server should NOT read registry or default hugs path stuff.  Instead,   all options are in the first argument in argv.   -- jcp */ DLLEXPORT(HugsServerAPI*) initHugsServer(argc, argv) /*server initialisation*/Int    argc;String argv[]; {     static Bool is_initialized = FALSE;     if (!is_initialized) {      is_initialized = TRUE;      setHugsAPI();            BEGIN_PROTECT			/* Too much text for protect()	   */      Int i;       startEvaluator();       if (argc == -1) {	readOptions(argv[0],FALSE);      } else {	readOptionSettings();	for (i=1; i<argc && (argv[i][0]=='+' || argv[i][0]=='-'); ++i) {	  if (!processOption(argv[i])) {	    setError("Unrecognised option");	    return NULL;	  }	}      }      EnableOutput(FALSE);      loadPrelude(); #ifndef NO_DYNAMIC_TYPES      addScriptName("Hugs.Dynamic",TRUE);#endif       readScripts(0);      everybody(RESET);#ifndef NO_DYNAMIC_TYPES      if (!linkDynamic()) {	setError("module Hugs.Dynamic doesn't define the expected functions");	return NULL;      }#endif      END_PROTECT   }   return &hugs;  /* error must have occurred */} /* Just give me the method table; initialisation is assumed to already have taken * place. Used when external code needs to callback into Haskell. */HugsServerAPI* getHugsAPI() {  setHugsAPI();  return &hugs;} /* -------------------------------------------------------------------------- * Shutting down: * ------------------------------------------------------------------------*/DLLEXPORT(Void) shutdownHugsServer(hserv) /* server shutdown */HugsServerAPI* hserv; {  /* The 'hserv' argument isn't actually used */  clearStack();  stopAnyPrinting();  everybody(EXIT);  stopEvaluator();  return;} /* -------------------------------------------------------------------------- * Dynamic typing * * We use dynamic typing to make the system more robust - all values pushed * on the stack have type "Dynamic" and we check the real type on function * application and evaluation.  This requires on functions and a class * defined in the HugsDynamic library. * * sof 2001 - interposing a Dynamic-typed layer sometimes gets in the way *            (missing Typeable instances, extra loading of modules), as *            has proven the case when using the HugsServerAPI by HaskellScript, *            Lambada, and mod_haskell. By defining NO_DYNAMIC_TYPES, *            you may turn this feature off. * ------------------------------------------------------------------------*/#ifndef NO_DYNAMIC_TYPESstatic Name  nameRunDyn;static Name  nameDynApp;static Name  nameToDyn;static Name  nameCoerceDynamic;static Class classTypeable; static Bool linkDynamic(){    nameRunDyn        = findName(findText("runDyn"));    nameDynApp        = findName(findText("dynApp"));    nameToDyn         = findName(findText("toDyn"));    nameCoerceDynamic = findName(findText("coerceDynamic"));    classTypeable     = findClass(findText("Typeable"));     return (   nonNull(nameRunDyn        )	    && nonNull(nameDynApp        )	    && nonNull(nameToDyn         )	    && nonNull(nameCoerceDynamic )	    && nonNull(classTypeable     ));}#endif /* -------------------------------------------------------------------------- * Miscellaneous: * ------------------------------------------------------------------------*/ static Int GetNumScripts()      /* Get number of scripts in system  */{    protect(return numLoadedScripts());    return 0;} static Void Reset(scripts) /* Restore number of scripts to old level */Int scripts; {    protect(	ClearOutputBuffer();	forgetScriptsFrom(scripts);	everybody(RESET);	);} static Void SetOutputEnable(f)    /* enable/disable compiler output  */Bool f;{    protect(EnableOutput(f));} static Void ChangeDir(s)          /* change current directory        */String s;{    protect(	if (chdir(s)) {	    setError("changeDir: invalid directory");	    return;	}	);} static Void LoadProject(fn)       /* load a project into the system  */String fn;{    protect(setError("loadProject: not implemented"));} static Void LoadFile(fn)          /* load a module (from a file) into the system   */String fn;{    protect(	addScriptName(fn,TRUE);	readScripts(numLoadedScripts());	everybody(RESET);	);} static Void LoadStringF(mod)      /* load a module (from a string) into the system   */String mod;{    protect(	addScriptName(mod,TRUE);	readScripts(numLoadedScripts());	everybody(RESET);	);} static Void SetOptions(opt)String opt; {  readOptions2(opt);  return;} static String GetOptions() {  return strCopy(optionsToStr());} static Bool SetModule(m)String m; {    Module mod   = findModule(findText(m));    if (isNull(mod)) {	return FALSE;    }    setCurrModule(mod);    return TRUE;} static HVal CompileExpr(m,e)    /* compile expression e wrt module m */String m;String e; {    BEGIN_PROTECT	Type type = NIL;	Cell d    = NIL;	HVal r    = 0; 	if (!SetModule(m)) {	    char errmsg[256];	    snprintf(errmsg, 255, "can't find \"%s\" module", m);	    setError(errmsg);	    return 0;	}	scriptFile = 0;	stringInput(e);                /* Put expression into input buffer */					startNewScript(0);             /* Enables recovery of storage      */				       /* allocated during evaluation      */	parseExp();	checkExp();	defaultDefns = evalDefaults;	type         = typeCheckExp(TRUE);#ifndef NO_DYNAMIC_TYPES	d = getTypeableDict(type);	if (isNull(d)) {	    setError("compileExpr: can't create Typeable instance");	    return 0;	}	inputExpr = ap(ap(nameToDyn,d),inputExpr);#endif	compileExp();	run(inputCode,sp);  /* Build graph for redex */ 	r = mkStablePtr(pop());	if (0 == r) {	    setError("compileExpr: no free stable pointers");	    return 0;	}	return r;    END_PROTECT    return 0;} static Void GarbageCollect(){    garbageCollect();} /* -------------------------------------------------------------------------- * Building expressions on the stack * ------------------------------------------------------------------------*/ static Void LookupName(m,v) /*Push value of qualified name onto stack*/String m,v;{    BEGIN_PROTECT	Name   n;	Cell   d;        char   errbuf[256]; 	if (!SetModule(m)) {	    snprintf(errbuf, 255, "lookupName: invalid module '%s'", m);	    setError(errbuf);	    return;	}	if (isNull(n = findName(findText(v)))) {            snprintf( errbuf, 255, "lookupName: invalid name '%s.%s'", m, v );	    setError(errbuf);	    return;	}#ifndef NO_DYNAMIC_TYPES	d = getTypeableDict(name(n).type);	if (isNull(d)) {	    setError("lookupName: can't create Typeable instance");	    return;	}	push(ap(ap(nameToDyn,d),n));#else	push(n);#endif    END_PROTECT} static Void MkInt(i)              /* Push an Int onto the stack      */Int i;{#ifndef NO_DYNAMIC_TYPES    Cell d = getTypeableDict(typeInt);    protect(push(ap(ap(nameToDyn,d),mkInt(i))));#else    protect(push(mkInt(i)));#endif} static Void MkAddr(a)              /* Push an Addr onto the stack      */void* a;{#ifndef NO_DYNAMIC_TYPES    Cell d = getTypeableDict(typeAddr);    protect(push(ap(ap(nameToDyn,d),mkPtr(a))));#else    protect(push(mkPtr(a)));#endif} static Void MkString(s)           /* Push a String onto the stack    */String s;{    BEGIN_PROTECT	pushString(s);#ifndef NO_DYNAMIC_TYPES	topfun(ap(nameToDyn,getTypeableDict(typeString)));#endif    END_PROTECT} static Void Apply()              /* Apply stack[sp-1] to stack[sp]   */

Lines 1–500 of 844. Load more