/* xlsubr - xlisp builtin function support routines *//*	Copyright (c) 1985, by David Michael Betz        All Rights Reserved        Permission is granted for unrestricted non-commercial use	*//* CHANGE LOG * -------------------------------------------------------------------- * 28Apr03  dm  eliminate some compiler warnings */#include "string.h"#include "xlisp.h"/* external variables */extern LVAL k_test,k_tnot,s_eql;/* xlsubr - define a builtin function */LVAL xlsubr(char *sname, int type, LVAL (*fcn)(void), int offset){    LVAL sym;    sym = xlenter(sname);    setfunction(sym,cvsubr(fcn,type,offset));    return (sym);}/* xlgetkeyarg - get a keyword argument */int xlgetkeyarg(LVAL key, LVAL *pval){    LVAL *argv=xlargv;    int argc=xlargc;    for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {        if (*argv == key) {            *pval = *++argv;            return (TRUE);        }    }    return (FALSE);}/* xlgkfixnum - get a fixnum keyword argument */int xlgkfixnum(LVAL key, LVAL *pval){    if (xlgetkeyarg(key,pval)) {        if (!fixp(*pval))            xlbadtype(*pval);        return (TRUE);    }    return (FALSE);}/* xltest - get the :test or :test-not keyword argument */void xltest(LVAL *pfcn, int *ptresult){    if (xlgetkeyarg(k_test,pfcn))	/* :test */        *ptresult = TRUE;    else if (xlgetkeyarg(k_tnot,pfcn))	/* :test-not */        *ptresult = FALSE;    else {        *pfcn = getfunction(s_eql);        *ptresult = TRUE;    }}/* xlgetfile - get a file or stream */LVAL xlgetfile(void){    LVAL arg;    /* get a file or stream (cons) or nil */    if ((arg = xlgetarg())) {        if (streamp(arg)) {            if (getfile(arg) == NULL)                xlfail("file not open");        }        else if (!ustreamp(arg))            xlerror("bad argument type",arg);    }    return (arg);}/* xlgetfname - get a filename */LVAL xlgetfname(void){    LVAL name;    /* get the next argument */    name = xlgetarg();    /* get the filename string */    if (symbolp(name))        name = getpname(name);    else if (!stringp(name))        xlerror("bad argument type",name);    /* return the name */    return (name);}/* needsextension - check if a filename needs an extension */int needsextension(char *name){    char *p;    /* check for an extension */    for (p = &name[strlen(name)]; --p >= &name[0]; )        if (*p == '.')            return (FALSE);        else if (!islower(*p) && !isupper(*p) && !isdigit(*p))            return (TRUE);    /* no extension found */    return (TRUE);}/* the next three functions must be declared as LVAL because they * are used in LVAL expressions, but they do not return anything * warning 4035 is "no return value" *//* #pragma warning(disable: 4035) *//* xlbadtype - report a "bad argument type" error */LVAL xlbadtype(LVAL arg){    xlerror("bad argument type",arg);    return NIL; /* never happens */}/* xltoofew - report a "too few arguments" error */LVAL xltoofew(void){    xlfail("too few arguments");    return NIL; /* never happens */}/* xltoomany - report a "too many arguments" error */LVAL xltoomany(void){    xlfail("too many arguments");    return NIL; /* never happens */}/* eq - internal eq function */int eq(LVAL arg1, LVAL arg2){    return (arg1 == arg2);}/* eql - internal eql function */int eql(LVAL arg1, LVAL arg2){    /* compare the arguments */    if (arg1 == arg2)        return (TRUE);    else if (arg1) {        switch (ntype(arg1)) {        case FIXNUM:            return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);        case FLONUM:            return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);        default:            return (FALSE);        }    }    else        return (FALSE);}/* lval_equal - internal equal function */int lval_equal(LVAL arg1, LVAL arg2){    /* compare the arguments */    if (arg1 == arg2)        return (TRUE);    else if (arg1) {        switch (ntype(arg1)) {        case FIXNUM:            return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);        case FLONUM:            return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);        case STRING:            return (stringp(arg2) ? strcmp((char *) getstring(arg1),                                           (char *) getstring(arg2)) == 0 : FALSE);        case CONS:            return (consp(arg2) ? lval_equal(car(arg1),car(arg2))                               && lval_equal(cdr(arg1),cdr(arg2)) : FALSE);        default:            return (FALSE);        }    }    else        return (FALSE);}