/** xprkermit.c
*
*   These are the protocol transfer routines for a simple Kermit upload/dnload
*
*   Version 0.9--by Marco Papa.
*
*   Version 1.0--updated by Stephen Walton.
*	Added several more user selections to XPRotocolSetup():
*	bctr (block check type to request), limit (retry-limit), and
*	rtimo (timeout for me).  "Real" C Kermit makes many of the
*	things declared as local to kermitproto.w user-settable,
*	such as the send packet size.
*	Also fixed several problems in kermitproto.w.
*
*   Version 1.5--more features
*	Extensive changes.
*	(1) Created a SetupVars variable to hold setting-up information
*	in the XPR_IO structure.  This will allow re-entrancy when and if
*	it comes.  Right now, it mainly gives a way to set up defaults with
*	one assignment.
*	(2) Added the generic Kermit server functions FINISH, BYE, and CD.
*	(3) Added the ability to set options and execute the server functions
*	from a setup string (sent as IO->xpr_filename to XPRotocolSetup()).
*
*	This code is copyright 1990 by Stephen Walton and Marco Papa.  It may
*	be freely distributed in its original or in modified form, provided
*	this copyright notice is kept intact.  It may not be sold for profit,
*	but may be included as part of a commercial program provided that
*	said inclusion does not increase the cost of that program beyond a
*	modest handling fee.
**/
#include <exec/exec.h>
#include <functions.h>
#include <stdio.h>

/*
 * xproto.h is the include file given in Appendix B.
 */

#include "xproto.h"
#include "xprkermit.h"
#include "kermitproto.h"

/*
 * The following two strings must exist.
 */
char            XPRname[] = "xprkermit.library";
char            XPRid[] = "xprkermit 1.5 (9 December 1989)\r\n";
UWORD           XPRrevision = 5;

long            atol();
/*
 * The callxx...() routines are described later. They provide the assembler
 * interface from the XPR library to the call-back routines.
 */
long
calla(), callaa(), callad(), calladd(), calladda(), calldaa(),
callda(), calld();

/* IMPORTANT: this makes it non-reentrant !!!! */
long            (*xupdate) (), (*xswrite) (), (*xfopen) (), (*xfclose) (), (*xfread) (),
                (*xsread) (), (*xchkabort) (), (*xfnext) (), (*xffirst) (), (*xsflush) (),
                (*xfwrite) (), (*xgets) (), (*xfinfo) ();

/*
 * External and forward declarations.
 */

char           *malloc(), *strcpy(), *index();
void            ioerr(), XPRLong();
SetupVars      *setup();
extern char     start;

/*
 * The flags for the kermitproto.w module.
 */
char           *p_pattern;	/* wildcard pattern */
int             parity;		/* parity on? 0 for no parity--need for
				 * proper 8th-bit quote */
int             text;		/* Text or binary mode? Flag 1 for text file,
				 * 0 for binary file	 */
int             convert;	/* Convert file names to lower case? 0 for
				 * literal files (no), 1 for translate (yes) */
int             urpsiz;		/* Kermit maximum packet size. Maximum
				 * receive packet size user wants.	 */
char           *cmarg;		/* Character string containing Kermit server
				 * cmd */

extern int      bctr;		/* Block check type to request. */
extern int      limit;		/* Retry limit.  May increase on very noisy
				 * lines. */
extern int      rtimo;		/* Timeout to request. */

int             getfile;	/* Host server. 0 = Receive (no) ; 1 = Get
				 * (yes) */
long            brkflag;

static SetupVars Defaults = {
    {""},			/* No default file name. */
    0,				/* Parity defaults to off. */
    1,				/* Text file defaults to on. */
    1,				/* Convert file names by default. */
    94,				/* Default maximum packet length. */
    1,				/* Default block check type. */
    5,				/* Retry limit */
    10,				/* Timeout (seconds) */
    0,				/* Host is server?  No by default. */
};

/**
*
*   Send a file
*
**/
long
XProtocolSend(IO)
    struct XPR_IO  *IO;
{
    struct XPR_UPDATE xpru;
    SetupVars      *sv;

    brkflag = 0;

    if ((sv = setup(IO)) == NULL)
	return 0L;		/* Initialize parameters. */
    /*
     * Read the text/binary set using xpr_finfo if present.  Else use the
     * value chosen in XPRotocolSetup.
     */
    if (xfinfo) {
	/*
	 * Use feature that calling xpr_finfo with a zero-length filename
	 * returns setting of internal comm program Text/Binary flag.
	 */
	text = (callad(xfinfo, IO->xpr_filename, 2L) == 1 ? 0 : 1);
    }
    /*
     * Start the transfer. See 3.8 for a discussion on how to implement
     * xupdate.
     */
    tchar('#');

    /*
     * Copy filename, and put pointer in external Kermit variable.
     */
    strcpy(sv->FileName, IO->xpr_filename);
    p_pattern = sv->FileName;
    /*
     * */
    start = 's';
    proto();

    /*
     * If we got here through chkabort() say Aborted.
     */
    xpru.xpru_updatemask = XPRU_MSG;
    if (brkflag)
	xpru.xpru_msg = "Aborted";
    else
	xpru.xpru_msg = "Done";
    (void) calla(xupdate, &xpru);
    if (brkflag)
	return (0L);
    else
	return (1L);
}


/**
*
*   Receive a file.
*
**/
long
XProtocolReceive(IO)
    struct XPR_IO  *IO;
{
    struct XPR_UPDATE xpru;
    long            status;
    SetupVars      *sv;


    brkflag = 0;

    if ((sv = setup(IO)) == NULL)
	return 0L;			/* Initialize parameters. */
    /*
     * Read the text/binary set using xpr_finfo if present.  Else use the
     * value chosen in XPRotocolSetup.
     */
    if (xfinfo) {
	/*
	 * Use feature th at calling xpr_finfo with a zero-length filename
	 * returns setting of internal comm program Text/Binary flag.
	 */
	text = (callad(xfinfo, "", 2L) == 1 ? 0 : 1);
    }
    /*
     * Start the transfer. See 3.8 for a discussion on how to implement
     * xupdate.
     */
    tchar('#');

    /*
     * */
    if (getfile) {
	/*
	 * Copy filename, and put pointer in external Kermit variable.
	 */
	cmarg = sv->FileName;
	start = 'r';
	status = callaa(xgets, "Host Filename", cmarg);
	if (!status)
	    return (0L);
    } else
	start = 'v';
    proto();

    /*
     * If we got here through chkabort() say Aborted.
     */
    xpru.xpru_updatemask = XPRU_MSG;
    if (brkflag)
	xpru.xpru_msg = "Aborted";
    else
	xpru.xpru_msg = "Done";
    (void) calla(xupdate, &xpru);
    if (brkflag)
	return (0L);
    else
	return (1L);
}

/*
 * Perform a generic Kermit server command.
 */
static
DoGeneric(IO, s)
    struct XPR_IO  *IO;
    char           *s;
{
    SetupVars *sv;

    if ((sv = setup(IO)) == NULL)
	return 0;			/* Set up transfer characteristics. */
    brkflag = 0;
    start = 'g';
    cmarg = s;
    proto();
    if (brkflag)
	return (0);
    else
	return (1);
}

/*
 * Execute a Kermit FINISH command.
 */
static
KermitFinish(IO)
    struct XPR_IO  *IO;
{
    return (DoGeneric(IO, "F"));
}

/*
 * Execute a Kermit BYE command.
 */
static
KermitBye(IO)
    struct XPR_IO  *IO;
{
    return (DoGeneric(IO, "L"));
}

/*
 * Change directory on remote server.  We need to return an error if the CD
 * fails on the remote end.
 */
static
KermitCd(IO, dir)
    struct XPR_IO  *IO;
    char           *dir;
{
    char            CdCommand[100];
    int             retval;

    CdCommand[0] = 'C';
    CdCommand[1] = tochar(strlen(dir));
    strcpy(CdCommand + 2, dir);
    retval = DoGeneric(IO, CdCommand);
    return retval;
}

#if AZTEC_C
/*
 * Case-independent string comparison for Aztec C. Modification of the
 * strcmp() routine from Henry Spencer's portable string library.  Depends on
 * a toupper() function (as opposed to macro).
 */

int				/* <0 for <, 0 for ==, >0 for > */
stricmp(s1, s2)
    char           *s1;
    char           *s2;
{
    register char  *scan1;
    register char  *scan2;

    scan1 = s1;
    scan2 = s2;
    while (*scan1 != '\0' && toupper(*scan1) == toupper(*scan2)) {
	scan1++;
	scan2++;
    }

    /*
     * The following case analysis is necessary so that characters which look
     * negative collate low against normal characters but high against the
     * end-of-string NUL.
     */
    if (*scan1 == '\0' && *scan2 == '\0')
	return (0);
    else if (*scan1 == '\0')
	return (-1);
    else if (*scan2 == '\0')
	return (1);
    else
	return (toupper(*scan1) - toupper(*scan2));
}

#endif

/**
*
*   Setup
*
* First, a general-purpose comparison for either of the two possible returns
* indicating a Yes push on a Boolean gadget.
**/

#define XprBoolTrue(s) ((stricmp(s, "yes") == 0) || (stricmp(s, "on") == 0))

/*
 * Then, a small set of code to initialize a string based on a value.
 */

#define XprSet(value, string) (value ? \
   (void) strcpy(string, YesString) : \
   (void) strcpy(string, NoString)) \

static char     YesString[] = "yes";
static char     NoString[] = "no";

/*
 * If Setup() succeeds, flag same.  Also, we don't need a file requester
 * on receive.
 */
#define SUCCESS (XPRS_SUCCESS | XPRS_NORECREQ)

long
XProtocolSetup(IO)
    struct XPR_IO  *IO;
{
    long            (*xupdate) (), (*xgets) (), (*xoptions) (), (*xfinfo) ();
    struct XPR_UPDATE xpru;
#define NOPTS 8
    struct xpr_option opt[NOPTS], *popt[NOPTS];
#define MAXSTRING 6
    char            ValueStrings[NOPTS][MAXSTRING];
    long            status;
    int             i, j;
    char            buf[256];
    SetupVars      *sv, tempvar;

    if ((xupdate = IO->xpr_update) == NULL)
	return (XPRS_FAILURE);
    if ((xgets = IO->xpr_gets) == NULL)
	return (XPRS_FAILURE);

    /*
     * Allocate memory for file name buffer and options if first call. Copy
     * defaults into it and then merge in user changes.
     */
    if ((sv = (SetupVars *) IO->xpr_data) == NULL) {
	if ((sv = (SetupVars *) malloc((unsigned) sizeof(SetupVars))) == NULL)
	    return XPRS_FAILURE;
	*sv = Defaults;
	IO->xpr_data = (long *) sv;
    }
    tempvar = *sv;
    /*
     * In order to use xpr_options, we must have all of the three conditions
     * which follow true.  Otherwise, either IO->xpr_filename is non-NULL, in
     * which case we assume it contains a setup string, or there is no
     * xpr_options, in which case we use xpr_gets to retrieve a setup string.
     */
    if (IO->xpr_filename == NULL &&
	IO->xpr_extension >= 1 &&
	(xoptions = IO->xpr_options) != NULL) {

	/*
	 * I use a counter, i, here, so that I can stick in more options
	 * without needing to change a lot of numbers.  I can also skip
	 * options dynamically, as in Text below.
	 */
#if 1
	i = 0;
	/* Announce us. */
	opt[i].xpro_description = "Kermit Commands 1.5";
	opt[i].xpro_type = XPRO_HEADER;
	opt[i].xpro_value = NULL;
	opt[i].xpro_length = 0;
	i++;
	/*
	 * First, do the Kermit server command items.
	 */
	opt[i].xpro_description = "Kermit FINISH";
	opt[i].xpro_type = XPRO_COMMAND;
	opt[i].xpro_value = NULL;
	opt[i].xpro_length = 0;
	i++;
	opt[i].xpro_description = "Kermit BYE";
	opt[i].xpro_type = XPRO_COMMAND;
	opt[i].xpro_value = NULL;
	opt[i].xpro_length = 0;
	i++;
	opt[i].xpro_description = "Kermit CD";
	opt[i].xpro_type = XPRO_COMMPAR;
	buf[0] = '\0';
	opt[i].xpro_value = buf;		/* Use buf to hold dir name. */
	opt[i].xpro_length = sizeof(buf) - 1;
	i++;
	opt[i].xpro_description = "Kermit Options";
	opt[i].xpro_type = XPRO_COMMAND;
	opt[i].xpro_value = NULL;
	opt[i].xpro_length = 0;
	i++;
	/* show requester after loading pointers */
	for (j = 0; j < i; j++)
	    popt[j] = &opt[j];
	status = callda(xoptions, (long) i, popt);
	/* check returned value */
	if (status == -1L)
	    return XPRS_FAILURE;
	/* Check returned value to see what we are to do. */
	i = 1;
	if (status & (1L << i))
	    return (KermitFinish(IO) ? SUCCESS : XPRS_FAILURE);
	i++;
	if (status & (1L << i))
	    return (KermitBye(IO) ? SUCCESS : XPRS_FAILURE);
	i++;
	if (status & (1L << i))
	    return (KermitCd(IO, opt[i].xpro_value) ? SUCCESS : XPRS_FAILURE);
#endif
	/* If we get to this point, we are to set options. */
	i = 0;			/* Start over. */
	opt[i].xpro_description = "Kermit Options 1.5";
	opt[i].xpro_type = XPRO_HEADER;
	opt[i].xpro_value = NULL;
	opt[i].xpro_length = 0;
	i++;
	/* Convert filename */
	opt[i].xpro_description = "Convert Filename";
	opt[i].xpro_type = XPRO_BOOLEAN;
	XprSet(tempvar.ConvertFlag, ValueStrings[i]);
	opt[i].xpro_value = ValueStrings[i];
	opt[i].xpro_length = MAXSTRING;
	i++;
	/* host is server */
	opt[i].xpro_description = "Host Server";
	opt[i].xpro_type = XPRO_BOOLEAN;
	XprSet(tempvar.GetFlag, ValueStrings[i]);
	opt[i].xpro_value = ValueStrings[i];
	opt[i].xpro_length = MAXSTRING;
	i++;
	/*
	 * file type -- only show this if xpr_finfo not present, or returns
	 * error when we try to get the file type.
	 */
	if ((xfinfo = IO->xpr_finfo) == NULL ||
	    (tempvar.TextFlag = (callad(xfinfo, "", 2L))) == 0) {
	    tempvar.TextFlag = -1;	/* Flag xfinfo failed. */
	    opt[i].xpro_description = "Text File";
	    opt[i].xpro_type = XPRO_BOOLEAN;
	    XprSet(tempvar.TextFlag, ValueStrings[i]);
	    opt[i].xpro_value = ValueStrings[i];
	    opt[i].xpro_length = MAXSTRING;
	    i++;
	} else
	    /*
	     * Switch to 0 for binary, 1 for text; xpr_finfo returns 1 for
	     * binary, 2 for text.
	     */
	    tempvar.TextFlag -= 1;
	/* Packet size */
	opt[i].xpro_description = "Packet Size";
	opt[i].xpro_type = XPRO_LONG;
	(void) sprintf(ValueStrings[i], "%-d", tempvar.MaxPacket);
	opt[i].xpro_value = ValueStrings[i];
	opt[i].xpro_length = MAXSTRING;
	i++;
	/* Block Check type */
	opt[i].xpro_description = "Block Check (1, 2, 3)";
	opt[i].xpro_type = XPRO_LONG;
	(void) sprintf(ValueStrings[i], "%-d", tempvar.BlockCheckType);
	opt[i].xpro_value = ValueStrings[i];
	opt[i].xpro_length = MAXSTRING;
	i++;
	/* Retry Limit */
	opt[i].xpro_description = "Maximum Retries";
	opt[i].xpro_type = XPRO_LONG;
	(void) sprintf(ValueStrings[i], "%-d", tempvar.RetryLimit);
	opt[i].xpro_value = ValueStrings[i];
	opt[i].xpro_length = MAXSTRING;
	i++;
	/* Timeout */
	opt[i].xpro_description = "Timeout (seconds)";
	opt[i].xpro_type = XPRO_LONG;
	(void) sprintf(ValueStrings[i], "%-d", tempvar.Timeout);
	opt[i].xpro_value = ValueStrings[i];
	opt[i].xpro_length = MAXSTRING;
	i++;
	/* show requester after loading pointers */
	for (j = 0; j < i; j++)
	    popt[j] = &opt[j];
	/* show requester */
	status = callda(xoptions, (long) i, popt);
	/* check returned value */
	if (status == -1L)
	    return XPRS_FAILURE;
	i = 1;			/* Skip header		 */
	if (status & (1L << i))
	    tempvar.ConvertFlag = XprBoolTrue(opt[i].xpro_value) ? 1 : 0;
	i++;
	if (status & (1L << i))
	    tempvar.GetFlag = XprBoolTrue(opt[i].xpro_value) ? 1 : 0;
	i++;
	if (xfinfo == NULL || tempvar.TextFlag == -1) {
	    if (status & (1L << i))
		tempvar.TextFlag = XprBoolTrue(opt[i].xpro_value) ? 1 : 0;
	    i++;
	}
	if (status & (1L << i))
	    tempvar.MaxPacket = atoi(opt[i].xpro_value);
	i++;
	if (status & (1L << i))
	    tempvar.BlockCheckType = atoi(opt[i].xpro_value);
	i++;
	if (status & (1L << i))
	    tempvar.RetryLimit = atoi(opt[i].xpro_value);
	i++;
	if (status & (1L << i))
	    tempvar.Timeout = atoi(opt[i].xpro_value);
    } else {
	if (IO->xpr_filename != NULL)
	    strcpy(buf, IO->xpr_filename);	/* Save setup string */
	else {			/* Prompt for command/options string */
	    sprintf(buf, "OC%c,G%c,T%c,P%d,B%d,R%d,O%d", tempvar.ConvertFlag ? 'Y' : 'N',
		    tempvar.GetFlag ? 'Y' : 'N', tempvar.TextFlag ? 'Y' : 'N', tempvar.MaxPacket,
	       tempvar.BlockCheckType, tempvar.RetryLimit, tempvar.Timeout);
	    if (callaa(xgets, "Kermit Options", buf) == 0)
		return XPRS_FAILURE;	/* Failed to set up? */
	}
	switch (buf[0]) {
	case 'F':
	    return (KermitFinish(IO) ? SUCCESS : XPRS_FAILURE);
	case 'B':
	    return (KermitBye(IO) ? SUCCESS : XPRS_FAILURE);
	case 'C':
	    return (KermitCd(IO, buf + 1) ? SUCCESS : XPRS_FAILURE);
	case 'O':
	    if (SetupFromString(IO, buf, &tempvar) == 0)
		return XPRS_FAILURE;
	    break;
	case '\0':
	    break;
	default:
	    ioerr(IO, "Unrecognized XPR Kermit setup string");
	    break;
	}
    }
    *sv = tempvar;		/* Copy setups into safe place. */
    /*
     * Return success and inform caller that we don't need a requester for
     * receive.
     */
    return SUCCESS;
}

static char Delimiters[] = " \t\r\n,";

SetupFromString(IO, s, sv)
    struct XPR_IO  *IO;
    char           *s;
    SetupVars      *sv;
{
    char           *p, *strtok();
    char            errbuf[50];

    if (*s != 'O')
	return 0;		/* Options string must start with O. */
    s++;			/* Skip leading O. */
    /*
     * Hunt for options with strtok.  We allow whitespace and commas to
     * separate options.
     */
    for (p = strtok(s, Delimiters); p != NULL; p = strtok(NULL, Delimiters)) {
	switch (*p++) {				/* Auto-increment to option */
	case 'C':				/* Case conversion. */	
	    if (*p == 'Y' || *p == 'N')
		sv->ConvertFlag = (*p == 'Y');
	    else
		ioerr(IO, "Illegal C option format (must be Y or N)");
	    break;
	case 'G':				/* Get files (Host server) */
	    if (*p == 'Y' || *p == 'N')
		sv->GetFlag = (*p == 'Y');
	    else
		ioerr(IO, "Illegal G option format (must be Y or N)");
	    break;
	case 'T':				/* Text file */
	    if (*p == 'Y' || *p == 'N')
		sv->TextFlag = (*p == 'Y');
	    else
		ioerr(IO, "Illegal T option format (must be Y or N)");
	    break;
	case 'P':				/* Maximum packet length */
	    sv->MaxPacket = atoi(p);
	    break;
	case 'B':				/* Block check type. */
	    sv->BlockCheckType = atoi(p);
	    break;
	case 'R':				/* Retry limit */
	    sv->RetryLimit = atoi(p);
	    break;
	case 'O':				/* Timeout */
	    sv->Timeout = atoi(p);
	    break;
	default:
	    sprintf(errbuf, "Illegal XPR Kermit option: %c", p[-1]);
	    ioerr(IO, errbuf);
	    break;
	}
    }
    return 1;
}

/**
*
*   Cleanup
*
**/
long
XProtocolCleanup(IO)
    struct XPR_IO  *IO;
{
    if (IO->xpr_data)
	free(IO->xpr_data);
    IO->xpr_data = NULL;

    return (1L);
}

int
XPRParity(IO)
    struct XPR_IO  *IO;
{
    long            (*xsetserial) ();
    struct XPR_UPDATE xpru;
    long            status;

    /* check out parity */
    if (xsetserial = IO->xpr_setserial) {
	status = calld(xsetserial, -1L);
	if (status & 0x00000001L)
	    return 1;
	else
	    return 0;
    } else
	return 0;		/* Assume no parity if can't tell. */
}

void
XPRLong(IO, i)
    struct XPR_IO  *IO;
    long            i;
{
    long            (*xupdate) ();
    struct XPR_UPDATE xpru;
    char            locbuf[80];

    if ((xupdate = IO->xpr_update) == NULL)
	return;
    /* debug: show long value */
    xpru.xpru_updatemask = XPRU_MSG;
    sprintf(locbuf, "%lx", i);
    xpru.xpru_msg = &locbuf[0];
    calla(xupdate, &xpru);
}

/*
 * Copy setup variables into the local copies.  If there are none, then
 * simply copy the defaults.
 */
static SetupVars *
setup(IO)
    struct XPR_IO  *IO;
{
    register SetupVars *Current;

    /*
     * These are the call-backs we need. If any of them isn't provided, quit.
     * Could do some error reporting if at least xupdate is there.
     */
    if ((xupdate = IO->xpr_update) == NULL)
	return (0L);
    if ((xswrite = IO->xpr_swrite) == NULL)
	return (0L);
    if ((xfopen = IO->xpr_fopen) == NULL)
	return (0L);
    if ((xfclose = IO->xpr_fclose) == NULL)
	return (0L);
    if ((xfread = IO->xpr_fread) == NULL)
	return (0L);
    if ((xsread = IO->xpr_sread) == NULL)
	return (0L);
    if ((xchkabort = IO->xpr_chkabort) == NULL)
	return (0L);
    if ((xfnext = IO->xpr_fnext) == NULL)
	return (0L);
    if ((xffirst = IO->xpr_ffirst) == NULL)
	return (0L);
    if ((xsflush = IO->xpr_sflush) == NULL)
	return (0L);
    if ((xfwrite = IO->xpr_fwrite) == NULL)
	return (0L);
    if ((xgets = IO->xpr_gets) == NULL)
	return (0L);
    xfinfo = IO->xpr_finfo;

    if (IO->xpr_data == NULL) {
	if ((IO->xpr_data = (long *) malloc((unsigned) sizeof(SetupVars)))
            == NULL) {
	    ioerr(IO, "Out of memory!");
	    return NULL;
	}
	Current = (SetupVars *) IO->xpr_data;
	*Current = Defaults;
    } else
	Current = (SetupVars *) IO->xpr_data;
    parity = Current->ParityFlag = XPRParity(IO);
    text = Current->TextFlag;
    convert = Current->ConvertFlag;
    urpsiz = Current->MaxPacket;
    bctr = Current->BlockCheckType;
    limit = Current->RetryLimit;
    rtimo = Current->Timeout;
    getfile = Current->GetFlag;
    return Current;
}

/*
 * Have the comm program display an error message for us, using a temporary
 * XPR_UPDATE structure; used to display errors before Vars gets allocated
 */
void
ioerr(IO, msg)
    struct XPR_IO  *IO;
    char           *msg;
{
    struct XPR_UPDATE xpru;
    long            (*xupdate) ();

    if (xupdate = IO->xpr_update) {
	xpru.xpru_updatemask = XPRU_ERRORMSG;
	xpru.xpru_errormsg = msg;
	(void) calla(xupdate, &xpru);
    }
}

#if AZTEC_C
/*
 * Simple, re-entrant versions of malloc() and free to replace the ones in
 * the Aztec C libraries.  The only reason to use these instead of AllocMem()
 * is that these remember the size of the stuff allocated.
 */

char *malloc(n)
unsigned n;
{
    long *p;

    if ((p = AllocMem((long) n + sizeof(long), MEMF_PUBLIC | MEMF_CLEAR)) == NULL)
	return NULL;
    p[0] = n;
    return ((char *) &p[1]);
}

free(p)
char *p;
{
    long *s = (long *) p;

    FreeMem(&s[-1], s[-1]);
    return 1;
}
#endif
/**
*
*   The following functions setup the proper registers for the call-back 
*   functions.
*
**/
#ifndef _lint

#asm
        public _callad
_callad:
        movea.l 8(sp),a0                ; Second argument goes in a0
        move.l  12(sp),d0               ; Third  argument goes in d0
/*
*   Now this is a trick to avoid using another register.
*   Charlie taught me this...
*/
        move.l  4(sp),-(sp)             ; First  argument is function
        rts

        public  _calladda
_calladda:
        movea.l 8(sp),a0                ; Second argument goes in a0
        move.l  12(sp),d0               ; Third  argument goes in d0
        move.l  16(sp),d1               ; Fourth argument goes in d1
        movea.l 20(sp),a1               ; Fifth  argument goes in a1
        move.l  4(sp),-(sp)             ; First  argument is function
        rts

        public  _calldaa
_calldaa:
        move.l  8(sp),d0                ; Second  argument goes in d0
        movea.l 12(sp),a0               ; Third argument goes in a0
        movea.l 16(sp),a1               ; Fourth argument goes in a1
        move.l  4(sp),-(sp)             ; First  argument is function
        rts

        public  _calla
_calla:
        movea.l 8(sp),a0                ; Second argument goes in a0
        move.l  4(sp),-(sp)             ; First  argument is function
        rts

        public  _calld
_calld:
        move.l  8(sp),d0                ; Second argument goes in d0
        move.l  4(sp),-(sp)             ; First  argument is function
        rts

        public  _callaa
_callaa:
        movea.l 8(sp),a0                ; Second argument goes in a0
        movea.l 12(sp),a1               ; Third  argument goes in a1
        move.l  4(sp),-(sp)             ; First  argument is function
        rts

        public  _callda
_callda:
        move.l  8(sp),d0                ; Second argument goes in d0
        movea.l 12(sp),a0               ; Third  argument goes in a0
        move.l  4(sp),-(sp)             ; First  argument is function
        rts

        public  _calladd
_calladd:
        movea.l  8(sp),a0               ; Second argument goes in a0
        move.l  12(sp),d0               ; Third  argument goes in d0
        move.l  16(sp),d1               ; Fourth argument goes in d1
        move.l  4(sp),-(sp)             ; First  argument is function
        rts

#endasm
/*
*   Could have added any other functions needed for other call-backs.
*   Could have written a fancier single one... Could've...
*/
#endif