/* --------------------------------------------------------------------------
 * Machine dependent code
 * RISCOS specific code provided by Bryan Scatergood, JBS
 * Macintosh specific code provided by Hans Aberg (haberg@matematik.su.se)
 * HaskellScript code and recursive directory search (now just one level)
 *  provided by Daan Leijen (leijen@fwi.uva.nl)
 *
 * 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: machdep.c,v $
 * $Revision: 1.1 $
 * $Date: 2008/11/30 09:11:36 $
 * ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
#include "connect.h"
#include "errors.h"
#include "opts.h"
#include "strutil.h"
#include "machdep.h"
#include "char.h"
#include "evaluator.h" /* everybody() proto only */

/*#define DEBUG_SEARCH*/

#if HAVE_SIGNAL_H
# include <signal.h>
#endif
#if HAVE_SYS_TYPES_H
# include <sys/types.h>
#else
# if HAVE_TYPES_H
#  include <types.h>
# endif
#endif
#if HAVE_SYS_PARAM_H
# include <sys/param.h>
#endif
#if HAVE_LIMITS_H
# include <limits.h>
#endif
#if HAVE_SYS_STAT_H
# include <sys/stat.h>
#else
# if HAVE_STAT_H
#  include <stat.h>
# endif
#endif
#if HAVE_DIRENT_H
#  include <dirent.h>
#endif

#ifndef MAXPATHLEN
#  define MAXPATHLEN 4096
#endif

/* --------------------------------------------------------------------------
 * Find information about a file:
 * ------------------------------------------------------------------------*/

Void getFileInfo(f,tm,sz)  /* find time stamp and size of file*/
String f;
Time   *tm;
Long   *sz; {
    struct stat scbuf;
    if (!stat(f,&scbuf)) {
	*tm = scbuf.st_mtime;
	*sz = (Long)(scbuf.st_size);
    } else {
	*tm = 0;
	*sz = 0;
    }
}


Bool readable(f,isReg)        /* is f readable (and also, a regular file?) */
String f;
Bool   isReg; {
    struct stat scbuf;
    return (!stat(f,&scbuf) 
	   && (!isReg || (scbuf.st_mode & S_IFREG))); /* regular file */
}


/* --------------------------------------------------------------------------
 * Search for script files on the HUGS path:
 * ------------------------------------------------------------------------*/

static String local homeDir	  Args((void));

#if 0
/* UNUSED */
static int    local pathCmp       Args((String, String));
#endif
static String local normPath      Args((String));
static Void   local searchChr     Args((Int));
static Void   local searchStr     Args((String));
static Bool   local tryEndings    Args((Void));
static Bool   local find1	  Args((String));
static Bool   local find2	  Args((String));
static String local expandVariable Args((String));
static String local skipVariable  Args((String));
static String local nextPath      Args((String));
static Bool   local samePath      Args((String,String));
static Bool   local scanSubDirs   Args((String));

# define SLASH                   '/'
# define isSLASH(c)              ((c)==SLASH)
# define PATHSEP                 ':'
# define isPATHSEP(x)            (*(x) == PATHSEP)

#if HAVE_GETMODULEFILENAME 
static HMODULE hugsModule = (HMODULE)0;
static String  hugsRoot   = 0;

extern Void setHugsModule Args((HMODULE));
extern Bool setHugsRoot   Args((String));

Void setHugsModule(hmod)
HMODULE hmod; {
    hugsModule = hmod;
}

Bool setHugsRoot(s)
String s; {
    String newRoot = malloc(strlen(s) + 1);
    
    if (!newRoot) return FALSE;
    
    strcpy(newRoot,s);
    
    if (hugsRoot) free(hugsRoot);
    hugsRoot = newRoot;
    return TRUE;
}

#endif


String hugsdir() {		/* directory containing libraries/Prelude.hs */

    /* On Unix systems, data is not typically stored relative to a binary
     * (it's also harder for a binary to determine where it lives).
     * First, check for an environment var, then fall back to
     * a configuration-time constant (--datadir=...).
     */
    char *hugsdir = getenv("HUGSDIR");
    return hugsdir ? hugsdir : HUGSDIR;
}

static String homeDir() {
    return getenv("HOME");
}

String local RealPath(s)         /* Find absolute pathname of file  */
String s; {
#if HAVE_REALPATH /* eg Unix */
    static char path[MAXPATHLEN+1];
    path[sizeof(path)-1] = '\0';
    if (strlen(s) <= (sizeof(path)-1)) {
	realpath(s,path);                
    } else {
	return s;
    }
#else
    static char path[FILENAME_MAX+1];

    path[sizeof(path)-1] = '\0';
    if (strlen(s) <= (sizeof(path)-1)) {
        strcpy(path,s);
    } else {
	return s;
    }
#endif
    return path;
}

#if 0
/* UNUSED */
static int local pathCmp(p1,p2)       /* Compare paths after normalisation */
String p1;
String p2; {
#if HAVE_REALPATH /* eg Unix */
    static char path1[MAXPATHLEN+1];
    static char path2[MAXPATHLEN+1];
    realpath(p1,path1);                
    realpath(p2,path2);                
#else
    static char path1[FILENAME_MAX+1];
    static char path2[FILENAME_MAX+1];
    strcpy(path1,p1);
    strcpy(path2,p2);
#endif
    return filenamecmp(path1,path2);
}
#endif

static String local normPath(s) /* Try, as much as possible, to normalize  */
String s; {                     /* a pathname in some appropriate manner.  */
    String path = RealPath(s);
    return path;
}

static char   searchBuf[FILENAME_MAX+1];
static Int    searchPos;

#define searchReset(n)          searchBuf[searchPos=(n)]='\0'

static Void local searchChr(c)  /* Add single character to search buffer   */
Int c; {
    if (searchPos<FILENAME_MAX) {
	searchBuf[searchPos++] = (char)c;
	searchBuf[searchPos]   = '\0';
    }
}

static Void local searchStr(s)  /* Add string to search buffer             */
String s; {
    while (*s && searchPos<FILENAME_MAX)
	searchBuf[searchPos++] = *s++;
    searchBuf[searchPos] = '\0';
}

static Bool local tryEndings()  /* Try each of the listed endings          */
{
    Int save;
    String sp;

    save = searchPos;
    sp = hugsSuffixes;
    while (*sp) {
	for ( ; *sp && ! isPATHSEP(sp); sp++)
	    if (searchPos<FILENAME_MAX)
		searchBuf[searchPos++] = *sp;
	searchBuf[searchPos] = '\0';
#if DEBUG_SEARCH
	Printf("trying '%s'\n", searchBuf);
#endif
	if (readable(searchBuf,TRUE))
	    return TRUE;
	if (*sp)
	    sp++;
	searchReset(save);
    }
    return FALSE;
}

/* scandir, June 98 Daan Leijen
   searches the direct subdirectories of a directory for a file
   (excluding directories that start with a dot)

   input: searchbuf contains base directory (not SLASH terminated)
	      argument name contains the module name
   output: TRUE: searchBuf contains the full filename
	   FALSE: searchBuf is garbage, file not found
*/
	  

#if HAVE_DIRENT_H

static Bool scanSubDirs(s)
String s;
{
    DIR *dir;
    struct dirent *entry;
    struct stat statb;
    int save;

    if ((dir = opendir(searchBuf)) == NULL)
	errno = 0;
    else {
	searchChr(SLASH);
	save = searchPos;
	while ((entry = readdir(dir)) != NULL)
            if (entry->d_name[0] != '.') {
		searchStr(entry->d_name);
		if (stat(searchBuf, &statb)==0 && S_ISDIR(statb.st_mode)) {
		    searchChr(SLASH);
		    if (find2(s)) {
			closedir(dir);
			return TRUE;
		    }
		}
		searchReset(save);
	    }
	closedir(dir);
    }
    return FALSE;
}

#else

static Bool scanSubDirs(name)
String name;
{   return FALSE;
}

#endif /* HAVE_WINDOWS_H || HAVE_DIRENT_H */

/* Variables that may be substituted in the path */

struct shellVariable {
    String var_name;
    String (*var_value) Args((Void));
};

static struct shellVariable shell_var[] = {
    { "Hugs",		&hugsdir },
    { "Home",		&homeDir },
    { 0, 0 }
};

/*
    findPathname nm = [ nm ++ e | e <- "" : hugsSuffixes ]
*/

String findPathname(filename)   /* Look for a file, trying various extensions */
String filename; {              /* Return ***input name*** if no file was found */
    searchReset(0);
    searchStr(filename);
#if DEBUG_SEARCH
    Printf("trying '%s'\n", searchBuf);
#endif
    if (!readable(searchBuf,TRUE) && !tryEndings())
	searchStr("");
    return normPath(searchBuf);
}

/* Finding the filename corresponding to a module name:

    find maybe_dir nm = [ d ++ map dot2slash nm ++ e | d <- dirs, e <- exts ]
      where 
        dirs          = maybeToList maybe_dir ++ hugsPath
        exts          = hugsSuffixes		-- default: [".hs",".lhs"]

	-- the dir is added if the importing module was found there, or
	-- was specified as an explicit filename.

        dot2slash c   = if c=='.' then slash else c
*/

String findMInDir(dir,nm)       /* Look for a module in the suggested dir */
String dir;                     /* Return NULL if no file was found       */
String nm; {
    searchReset(0);
    searchStr(dir);
    searchChr(SLASH);
    if (find2(nm)) {
        return normPath(searchBuf);
    } else {
        return NULL;
    }
}

String findMPathname(name)	    /* Look for a module                      */
String name; {                      /* Return NULL if no file was found       */
    if (find1(name)) {
        return normPath(searchBuf);
    } else {
        return NULL;
    }
}

static Bool find1(name)		/* Search each directory of the path */
String name; {
    String pathpt = hugsPath;
    String value;

    searchReset(0);		/* look along the HUGSPATH */
    if (pathpt) {
	while (*pathpt) {
	    searchReset(0);
	    if ((value=expandVariable(pathpt)) != NULL) {
		searchStr(value);
		pathpt = skipVariable(pathpt);
	    }
	    while (*pathpt && !isPATHSEP(pathpt))
		searchChr(*pathpt++);
	    /* If the path entry ends in SLASH '*', search immediate subdirs */
	    if (searchPos >= 2 && isSLASH(pathpt[-2]) && pathpt[-1] == '*') {
		searchPos -= 2;
		searchBuf[searchPos] = '\0';
		if (scanSubDirs(name))
		    return TRUE;
	    } else {
		searchChr(SLASH);
		if (find2(name))
		    return TRUE;
	    }
	    if (isPATHSEP(pathpt))
		pathpt++;
	}
    } 
    return FALSE;    
}

/* Expansion of initial MPW-style "shell-variables" of the form {varname} */
static String local expandVariable(pathpt)
String pathpt; {
    if (*pathpt=='{') {
	int i, len;

	for (i = 0; shell_var[i].var_name!=NULL; i++) {
	    len = strlen(shell_var[i].var_name);
	    if (strncmp(pathpt+1,shell_var[i].var_name,len)==0
		&& pathpt[len+1]=='}') {
		return (*shell_var[i].var_value)();
	    }
	}
    }
    return NULL;
}

/* Assuming expandVariable(pathpt) succeeded, skip past the variable */
static String local skipVariable(pathpt)
String pathpt; {
    return strchr(pathpt+1,'}')+1;
}

static Bool local find2(s)	/* Turn module name into a filename */
String s; {
    String sp;

    /* replace all dots in the module name with slashes */
    for (sp = s; *sp; sp++) {
	searchBuf[searchPos++] = *sp == '.' ? SLASH : *sp;
    }
    return tryEndings();
}

String dirname(filename)	/* Return the directory part of the filename */
String filename; {		/* or "." if no directory.                   */
    String slash = strrchr(filename,SLASH);
    if (!slash) {
	return strCopy(".");
    } else {
	return strnCopy(filename, slash - filename);
    }
}

/* --------------------------------------------------------------------------
 * Substitute old value of path into empty entries in new path
 * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
 * ------------------------------------------------------------------------*/

String local substPath(new,sub) /* substitute sub path into new path*/
String new;
String sub; {
    Bool   substituted = FALSE;            /*   only allow one replacement */
    Int    maxlen      = strlen(sub) + strlen(new);    /* safe upper bound */
    String r = (String) malloc(maxlen+1);  /* result string                */
    String t = r;                          /* pointer into r               */
    String next = new;                     /* next uncopied char in new    */
    String start = next;                   /* start of last path component */
    if (r == 0) {
	ERRMSG(0) "String storage space exhausted"
	EEND;
    }
    do {
	if (isPATHSEP(next) || *next == '\0') {
	    if (!substituted && next == start) {
		String s = sub;
		for(; *s != '\0'; ++s) {
		    *t++ = *s;
		}
		substituted = TRUE;
	    }
	    start = next+1;
	}
    } while ((*t++ = *next++) != '\0');
    return uniqPath(r);
}

/* Remove duplicates from the path */
String uniqPath(path)
String path; {
    char *pp;
    for (pp = path; *pp; ) {
	char *prev;
	char *next = nextPath(pp);
	for (prev = path; prev != pp; prev = nextPath(prev))
	    if (samePath(prev,pp))
		break;
	if (prev == pp)		/* not found: keep entry */
	    pp = next;
	else if (*next)		/* found in middle: delete entry */
	    strcpy(pp, next);
	else {			/* found at end: delete last entry */
	    if (pp != path)
		pp--;
	    *pp = '\0';
	}
    }
    return realloc(path, strlen(path)+1);
}

/* Advance to the start of the next entry in the path list */
static String local nextPath(pp)
String pp; {
    while (*pp && !isPATHSEP(pp))
	pp++;
    if (*pp)
	pp++;
    return pp;
}

static Bool local samePath(pp1, pp2)
String pp1, pp2; {
    char *ppsave1, *ppsave2;
    char *value;

    /* initial substitution variable? */
    if ((value=expandVariable(pp1)) != NULL) {
	ppsave1 = skipVariable(pp1);
	pp1 = value;
    } else
	ppsave1 = 0;
    if ((value=expandVariable(pp2)) != NULL) {
	ppsave2 = skipVariable(pp2);
	pp2 = value;
    } else
	ppsave2 = 0;

    while (*pp1 && !isPATHSEP(pp1) && *pp2 && !isPATHSEP(pp2)) {
	if (*pp1 != *pp2)
	    return FALSE;
	if (*++pp1 == '\0' && ppsave1 != 0) {	/* end of substitution */
	    pp1 = ppsave1;
	    ppsave1 = 0;
	}
	if (*++pp2 == '\0' && ppsave2 != 0) {	/* end of substitution */
	    pp2 = ppsave2;
	    ppsave2 = 0;
	}
    }
    return (*pp1=='\0' || isPATHSEP(pp1)) && (*pp2=='\0' || isPATHSEP(pp2));
}

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

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);
}

/* --------------------------------------------------------------------------
 * Get time/date stamp for inclusion in compiled files:
 * ------------------------------------------------------------------------*/

#if PROFILING
String timeString() {                   /* return time&date string         */
    time_t clock;                       /* must end with '\n' character    */
    time(&clock);
    return(ctime(&clock));
}
#endif

/* --------------------------------------------------------------------------
 * Garbage collection notification:
 * ------------------------------------------------------------------------*/

Bool gcMessages = FALSE;                /* TRUE => print GC messages       */

Void gcStarted() {                      /* Notify garbage collector start  */
    if (gcMessages) {
	Printf("{{Gc");
	FlushStdout();
    }
}

Void gcScanning() {                     /* Notify garbage collector scans  */
    if (gcMessages) {
	Putchar(':');
	FlushStdout();
    }
}

Void gcRecovered(recovered)		/* Notify garbage collection done  */
Int recovered; {
    if (gcMessages) {
	Printf("%d}}",recovered);
	FlushStdout();
    }
}

Cell *CStackBase;                       /* Retain start of C control stack */


                  /* Garbage collection for standard stack machines  */

Void gcCStack() {                       /* Garbage collect elements off    */
    Cell stackTop = NIL;                /* C stack                         */
    Cell *ptr = &stackTop;
#if SIZEOF_INTP == 2
    if (((long)(ptr) - (long)(CStackBase))&1)
	fatal("gcCStack");
#elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
    if (((long)(ptr) - (long)(CStackBase))&1)
	fatal("gcCStack");
#else 
    if (((long)(ptr) - (long)(CStackBase))&3)
	fatal("gcCStack");
#endif

#define StackGrowsDown  while (ptr<=CStackBase) markWithoutMove(*ptr++)
#define StackGrowsUp    while (ptr>=CStackBase) markWithoutMove(*ptr--)
#define GuessDirection  if (ptr>CStackBase) StackGrowsUp; else StackGrowsDown

#if STACK_DIRECTION > 0
    StackGrowsUp;
#elif STACK_DIRECTION < 0
    StackGrowsDown;
#else
    GuessDirection;
#endif

#if SIZEOF_INTP==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
    ptr = (Cell *)((long)(&stackTop) + 2);
    StackGrowsDown;
#endif

#undef  StackGrowsDown
#undef  StackGrowsUp
#undef  GuessDirection
}


/* --------------------------------------------------------------------------
 * Terminal dependent stuff:
 * ------------------------------------------------------------------------*/

Int getTerminalWidth() {
    return 80;
}

Void normalTerminal() {                 /* restore terminal initial state  */
}

Bool getEchoTerminal(Int fd) {
    return fd==0;
}

Void setEchoTerminal(Int fd, Bool echo) {
}

Bool getBuffTerminal(Int fd) {
    return fd==0;
}

Void setBuffTerminal(Int fd, Bool buffered) {
}

#if 0
Int readTerminalChar() {                /* read character from terminal    */
    if (terminalEchoReqd) {
	return getchar();
    } else {

	Int c = getch();
	return c=='\r' ? '\n' : c;      /* slight paranoia about CR-LF    */
    }
}
#endif

/* --------------------------------------------------------------------------
 * Interrupt handling:
 * ------------------------------------------------------------------------*/

Bool    broken         = FALSE;		/* pending break to be handled     */
static  Bool breakReqd = FALSE;		/* currently trapping breaks       */
static  Bool trapBreak = FALSE;		/* ever asked to trap breaks       */
static  sigProto(ignoreBreak);
static  Void local installHandlers Args((Void));

Bool breakOn(reqd)                      /* set break trapping on if reqd,  */
Bool reqd; {                            /* or off otherwise, returning old */
    Bool old  = breakReqd;

    breakReqd = reqd;
    if (reqd) {
	trapBreak = TRUE;
	if (broken) {                   /* repond to break signal received */
	    broken = FALSE;             /* whilst break trap disabled      */
	    sigRaise(breakHandler);
	    /* not reached */
	}
#if HANDLERS_CANT_LONGJMP
	ctrlbrk(ignoreBreak);
#else
	ctrlbrk(breakHandler);
#endif
    } else if (trapBreak) {		/* If we have been trapping breaks, */
	ctrlbrk(ignoreBreak);		/* switch to deferring them.        */
    }
    return old;
}

static sigHandler(ignoreBreak) {        /* record but don't respond to break*/
    ctrlbrk(ignoreBreak);         /* reinstall signal handler               */
				  /* redundant on BSD systems but essential */
				  /* on POSIX and other systems             */
    broken = TRUE;
    sigResume;
}


static Void local installHandlers() { /* Install handlers for all fatal    */ 
				      /* signals except SIGINT and SIGBREAK*/
/*
 *#ifdef SIGABRT
 *   signal(SIGABRT,panic);
 *#endif
 *#ifdef SIGBUS
 *   signal(SIGBUS,panic);
 * #endif
 * #ifdef SIGFPE
 *    signal(SIGFPE,panic);
 * #endif
 *#ifdef SIGHUP
 *    signal(SIGHUP,panic);
 *#endif
 *#ifdef SIGILL
 *    signal(SIGILL,panic);
 *#endif
 *#ifdef SIGQUIT
 *    signal(SIGQUIT,panic);
 *#endif
 *#ifdef SIGSEGV
 *    signal(SIGSEGV,panic);
 *#endif
 *#ifdef SIGTERM
 *    signal(SIGTERM,panic);
 *#endif
 */
}

/* --------------------------------------------------------------------------
 * Shell escapes:
 * ------------------------------------------------------------------------*/

Int
shellEsc(cmd, sync, useShell)         /* run a shell command (or shell)  */
String cmd;
Bool   sync;
Bool   useShell; {

#  if HAVE_BIN_SH
    if (cmd[0]=='\0') {
	cmd = fromEnv("SHELL","/bin/sh");
    }
# endif
    return system(cmd);
}

/* --------------------------------------------------------------------------
 * Floating point support:
 * ------------------------------------------------------------------------*/

#if FLOATS_SUPPORTED
#if BREAK_FLOATS
static union {
    Float  flVal;
    struct {
	Cell flPart1,flPart2;
    }      clVal;
} fudgeCoerce;

Cell bfTemp = NIL;

Cell mkFloat(fl)
FloatPro fl; {
    Cell p1,p2;
    fudgeCoerce.flVal = fl;
    bfTemp = mkInt(fudgeCoerce.clVal.flPart1);
    p2     = mkInt(fudgeCoerce.clVal.flPart2);
    p1     = bfTemp;
    bfTemp = NIL;
    return pair(FLOATCELL,pair(p1,p2));
}

FloatPro floatOf(c)
Cell c; {
    fudgeCoerce.clVal.flPart1 = intOf(fst(snd(c)));
    fudgeCoerce.clVal.flPart2 = intOf(snd(snd(c)));
    return fudgeCoerce.flVal;
}

#else /* !BREAK_FLOATS */
static union {
    Float flVal;
    Cell  clVal;
} fudgeCoerce;

Cell mkFloat(fl)
FloatPro fl; {
    fudgeCoerce.flVal = (Float)fl;
    return pair(FLOATCELL,fudgeCoerce.clVal);
}

FloatPro floatOf(c)
Cell c; {
    fudgeCoerce.clVal = snd(c);
    return fudgeCoerce.flVal;
}
#endif /* !BREAK_FLOATS */

String floatToString(fl)                     /* Make sure that floating    */
FloatPro fl; {                               /* point values print out in  */
    static char buffer1[32];                 /* a form in which they could */
    static char buffer2[32];                 /* also be entered as floats  */
    Int i=0, j=0;

    sprintf(buffer1,FloatFMT,fl);
    while (buffer1[i] && strchr("eE.",buffer1[i])==0)
	buffer2[j++] = buffer1[i++];
    if (buffer1[i]=='\0') {
        sprintf(buffer1,"%.1f",fl);
        i = j = 0;
    } else if (buffer1[i]!='.') {
	buffer2[j++] = '.';
	buffer2[j++] = '0';
    }
    while ((buffer2[j++]=buffer1[i++])!=0) {
    }
    return buffer2;
}

static union {
    Double  dblVal;
    struct {
	Cell dblPart1,dblPart2;
    }      cdVal;
} fudgeDCoerce;

Cell part1Double(dbl)
DoublePro dbl; {
    fudgeDCoerce.dblVal = dbl;
    return fudgeDCoerce.cdVal.dblPart1;
}

Cell part2Double(dbl)
DoublePro dbl; {
    fudgeDCoerce.dblVal = dbl;
    return fudgeDCoerce.cdVal.dblPart2;
}

DoublePro doubleFromParts(c1,c2)
Cell c1, c2; {
    fudgeDCoerce.cdVal.dblPart1 = c1;
    fudgeDCoerce.cdVal.dblPart2 = c2;
    return fudgeDCoerce.dblVal;
}

Cell bdTemp = NIL;

Cell mkDouble(dbl)
DoublePro dbl; {
    Cell p1,p2;
    fudgeDCoerce.dblVal = dbl;
    bdTemp = mkInt(fudgeDCoerce.cdVal.dblPart1);
    p2     = mkInt(fudgeDCoerce.cdVal.dblPart2);
    p1     = bdTemp;
    bdTemp = NIL;
    return pair(DOUBLECELL,pair(p1,p2));
}

DoublePro doubleOf(c)
Cell c; {
    fudgeDCoerce.cdVal.dblPart1 = intOf(fst(snd(c)));
    fudgeDCoerce.cdVal.dblPart2 = intOf(snd(snd(c)));
    return fudgeDCoerce.dblVal;
}

String doubleToString(dbl)                   /* Make sure that floating    */
DoublePro dbl; {                             /* point values print out in  */
    static char buffer1[32];                 /* a form in which they could */
    static char buffer2[32];                 /* also be entered as doubles */
    Int i=0, j=0;

    sprintf(buffer1,DoubleFMT,dbl);
    while (buffer1[i] && strchr("eE.",buffer1[i])==0)
	buffer2[j++] = buffer1[i++];
    if (buffer1[i]=='\0') {
        sprintf(buffer1,"%.1f",dbl);
        i = j = 0;
    } else if (buffer1[i]!='.') {
	buffer2[j++] = '.';
	buffer2[j++] = '0';
    }
    while ((buffer2[j++]=buffer1[i++])!=0) {
    }
    return buffer2;
}

DoublePro stringToDouble(s)
String s; {
    return atof(s);
}
#else /* !FLOATS_SUPPORTED */
Cell mkFloat(fl)
FloatPro fl; {
    internal("mkFloat");
    return 0;/*NOTREACHED*/
}

FloatPro floatOf(c)
Cell c; {
    internal("floatOf");
    return 0;/*NOTREACHED*/
}

String floatToString(fl)
FloatPro fl; {
    internal("floatToString");
    return "";/*NOTREACHED*/
}

Cell part1Double(dbl)
DoublePro dbl; {
    internal("part1Double");
    return 0;/*NOTREACHED*/
}

Cell part2Double(dbl)
DoublePro dbl; {
    internal("part2Double");
    return 0;/*NOTREACHED*/
}

DoublePro doubleFromParts(c1,c2)
Cell c1, c2; {
    internal("doubleFromParts");
    return 0;/*NOTREACHED*/
}

Cell mkDouble(fl)
DoublePro fl; {
    internal("mkDouble");
    return 0;/*NOTREACHED*/
}

DoublePro doubleOf(c)
Cell c; {
    internal("doubleOf");
    return 0;/*NOTREACHED*/
}

String doubleToString(fl)
DoublePro fl; {
    internal("doubleToString");
    return "";/*NOTREACHED*/
}
#endif /* !FLOATS_SUPPORTED */

/*---------------------------------------------------------------------------
 * Int64-related operations:
 *-------------------------------------------------------------------------*/

#if PROVIDE_INT64
Int part1Int64(i)
HsInt64 i; {
    return (Int)(i >> 32);
}

Int part2Int64(i)
HsInt64 i; {
    return (Int)(i);
}

HsInt64 int64FromParts(c1,c2)
Int c1, c2; {
    return ((HsInt64)c1 << 32) | (HsInt64)((HsWord32)c2);
}
#endif /* PROVIDE_INT64 */

/*---------------------------------------------------------------------------
 * Printf-related operations:
 *-------------------------------------------------------------------------*/

#if !HAVE_VSNPRINTF
int vsnprintf(char* buffer, size_t count, const char* fmt, va_list ap);
int vsnprintf(char* buffer, size_t count, const char* fmt, va_list ap) {
#if HAVE__VSNPRINTF
    return _vsnprintf(buffer, count, fmt, ap);
#else
    return 0;
#endif
}
#endif /* HAVE_VSNPRINTF */

#if !HAVE_SNPRINTF && !HAVE__SNPRINTF
int snprintf(char* buffer, size_t count, const char* fmt, ...);
int snprintf(char* buffer, size_t count, const char* fmt, ...) {
#if HAVE_VSNPRINTF || HAVE__VSNPRINTF
    int r;
    va_list ap;                    /* pointer into argument list           */
    va_start(ap, fmt);             /* make ap point to first arg after fmt */
    r = vsnprintf(buffer, count, fmt, ap);
    va_end(ap);                    /* clean up                             */
    return r;
#else
    return 0;
#endif
}
#endif /* HAVE_SNPRINTF */

/* --------------------------------------------------------------------------
 * Platform initialisation 
 * ------------------------------------------------------------------------*/
extern Bool initSystem  Args((Void));
Bool local
initSystem()
{
  /* Called right away by main()  */
    return TRUE;
}

/* --------------------------------------------------------------------------
 * Machine dependent control:
 * ------------------------------------------------------------------------*/

Void machdep(what)                      /* Handle machine specific         */
Int what; {                             /* initialisation etc..            */
    switch (what) {
	case MARK    :
#if FLOATS_SUPPORTED
#if BREAK_FLOATS
		       mark(bfTemp);
#endif
		       mark(bdTemp);
#endif
		       break;
	case INSTALL : installHandlers();
		       break;
	case RESET   :
#if FLOATS_SUPPORTED
#if BREAK_FLOATS
		       bfTemp = NIL;
#endif
		       bdTemp = NIL;
#endif
	case BREAK   :
	case EXIT    : normalTerminal();
		       break;
    }
}

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