/* openmath.c Copyright (C) 1998 NAG Ltd. */
#ifdef OPENMATH
/*
* Reading and writing of OpenMath objects, using the INRIA OpenMath library.
* Developed as a deliverable of the OpenMath Project (ESPRIT Project 24969).
*
* Initial version: Vilya Harvey, Nov 24th, 1998.
*
* Note: to add this to CCL, the following files had to be modified:
* Makefile
* cslbase\entries.h
* cslbase\externs.h
* cslbase\restart.c
* cclbase\exports.lsp
*
* Note: to make sure that the OpenMath support is compiled into CCL, the
* symbol OPENMATH must be #defined.
*/
/* Signature: 52632b41 08-Apr-2002 */
#include <stdarg.h>
#include <string.h>
#include <ctype.h>
#ifdef __WATCOMC__
#include <float.h>
#endif
#include "machine.h"
#include "tags.h"
#include "cslerror.h"
#include "externs.h"
#include "entries.h"
#include "arith.h"
#include "read.h"
#include <OM.h>
#include <OMconn.h>
#include <math.h>
#include "openmath.h"
#define OMCCL_ELEM_BITS 31 /* #bits in bignum element. */
#define OMCCL_MAX_BITS 15 /* Must be < OMCCL_ELEM_BITS */
#define OMCCL_MAX_VAL (1 << OMCCL_MAX_BITS)
#define OMCCL_MAX_MASK (OMCCL_MAX_VAL - 1)
#define OMCCL_INV_LOG_2 1.44269504 /* 1 / ln(2) */
/*
* Error reporting macro. The status parameter should be of type OMstatus; the
* return value is a Lisp_Object representing the appropriate error.
*/
#define om_error(status) error(0, (int)(status) + 33)
/*
* Local functions for dealing with property lists.
*/
Lisp_Object om_getLispProperty(Lisp_Object obj, Lisp_Object name);
Lisp_Object om_setLispProperty(Lisp_Object obj, Lisp_Object name, Lisp_Object val);
/*
* External CCL functions.
*/
extern char *get_string_data(Lisp_Object name, char *why, int32 *l);
OMdev
om_toDev(Lisp_Object obj)
/* This routine converts a Lisp_Object to an OMdev. It does
* not check that the object it is given actually *is* an
* OMdev - that's the caller's responsibility.
*/
{
OMdev dev;
/* DEBUG */
if (!is_bignum(obj)) {
err_printf("[om_toDev] not a bignum!\n");
}
else {
int blen = (bignum_length(obj) >> 2) - 1;
if (blen != 1)
err_printf("[om_toDev] bignum length is %d (should be 1)!\n", blen);
}
/* END DEBUG */
if (!is_bignum(obj))
return NULL;
else if (((bignum_length(obj) >> 2) - 1) != 1)
return NULL;
dev = (OMdev) ( bignum_digits(obj)[0] );
return dev;
}
Lisp_Object
om_fromDev(OMdev dev)
{
Lisp_Object obj;
obj = make_one_word_bignum((int32)dev);
return obj;
}
OMstatus
om_toStatus(Lisp_Object obj)
{
OMstatus status;
if (!is_fixnum(obj))
return OMinternalError;
status = (OMstatus)( int_of_fixnum(obj) );
return status;
}
Lisp_Object
om_fromStatus(OMstatus status)
{
Lisp_Object obj;
obj = fixnum_of_int((int32)status);
return obj;
}
OMencodingType
om_toEncodingType(Lisp_Object obj)
{
OMencodingType enc;
if (!is_fixnum(obj))
return OMencodingUnknown;
enc = (OMencodingType)( int_of_fixnum(obj) );
return enc;
}
Lisp_Object
om_fromEncodingType(OMencodingType enc)
{
Lisp_Object obj;
obj = fixnum_of_int((int32)enc);
return obj;
}
char *
om_toBigNumStr(Lisp_Object num)
{
static char hexdigit[] = "0123456789ABCDEF";
char *str;
int numDigits, digit;
int bdigit, boffset;
int i, j, val;
int strPos;
int leading;
/* Determine the number of digits needed. */
i = ((bignum_length(num) >> 2) - 1) * 31;
numDigits = (i >> 2) + (((i & 0x3) != 0) ? 1 : 0);
str = (char *)malloc((numDigits + 1) * sizeof(char));
memset(str, 0, (numDigits + 1) * sizeof(char));
strPos = 0;
leading = 1;
digit = 0;
while (digit < numDigits) {
i = (numDigits - digit - 1) << 2;
bdigit = i / 31;
boffset = i % 31;
j = 31 - boffset;
switch (j) {
case 3:
val = (bignum_digits(num)[bdigit] >> boffset) & 0x7;
val |= ((bignum_digits(num)[bdigit+1] & 0x1) << 3);
break;
case 2:
val = (bignum_digits(num)[bdigit] >> boffset) & 0x3;
val |= ((bignum_digits(num)[bdigit+1] & 0x3) << 2);
break;
case 1:
val = (bignum_digits(num)[bdigit] >> boffset) & 0x1;
val |= ((bignum_digits(num)[bdigit+1] & 0x7) << 1);
break;
default:
val = (bignum_digits(num)[bdigit] >> boffset) & 0xF;
break;
}
str[strPos] = hexdigit[val];
digit++;
if (hexdigit[val] != '0' || !leading) {
leading = 0;
strPos++;
}
}
return str;
}
Lisp_Object
om_fromBigNumStr(char *inData, int len, int sign, OMbigIntType fmt)
{
Lisp_Object obj, radix, digit;
int i;
if (len == 0)
return fixnum_of_int(0);
else
obj = fixnum_of_int(0);
switch (fmt) {
case OMbigIntBase10:
radix = fixnum_of_int(10);
break;
case OMbigIntBase16:
radix = fixnum_of_int(16);
break;
default:
return om_error(OMinternalError);
}
for (i = 0; i < len; i++) {
obj = times2(obj, radix);
switch (fmt) {
case OMbigIntBase10:
digit = fixnum_of_int( (int)(inData[i] - '0') );
break;
case OMbigIntBase16:
if (inData[i] >= 'a' && inData[i] <= 'f')
digit = fixnum_of_int( (int)(inData[i] - 'a') + 10 );
else if (inData[i] >= 'A' && inData[i] <= 'F')
digit = fixnum_of_int( (int)(inData[i] - 'A') + 10 );
else
digit = fixnum_of_int( (int)(inData[i] - '0') );
break;
}
obj = plus2(obj, digit);
}
if (sign < 0)
obj = negateb(obj);
return obj;
}
OMconn
om_toConn(Lisp_Object obj)
{
OMconn conn;
/* DEBUG */
if (!is_bignum(obj)) {
err_printf("[om_toConn] not a bignum!\n");
}
else {
int blen = (bignum_length(obj) >> 2) - 1;
if (blen != 1)
err_printf("[om_toConn] bignum length is %d (should be 1)!\n", blen);
}
/* END DEBUG */
if (!is_bignum(obj))
return NULL;
else if (((bignum_length(obj) >> 2) - 1) != 1)
return NULL;
conn = (OMconn)(bignum_digits(obj)[0]);
return conn;
}
Lisp_Object
om_fromConn(OMconn conn)
{
Lisp_Object obj;
obj = make_one_word_bignum((int32)conn);
return obj;
}
char **
om_toCString(Lisp_Object obj)
/* Converts a lisp object which wraps a C string into a C string (a char
* pointer, where the memory block is allocated on the heap, outside of the
* control of the CCL garbage collection). Does not check that the Lisp object
* *is* a C string though.
*/
{
char **pstr = NULL;
/* DEBUG */
if (!is_bignum(obj) && !stringp(obj)) {
err_printf("[om_toCString] not a bignum or a string!\n");
}
else if (is_bignum(obj)) {
int blen = (bignum_length(obj) >> 2) - 1;
if (blen != 1)
err_printf("[om_toCString] bignum length is %d (should be 1)!\n", blen);
}
/* END DEBUG */
if (!is_bignum(obj) && !stringp(obj))
return NULL;
else if (is_bignum(obj)) {
if (((bignum_length(obj) >> 2) - 1) != 1)
return NULL;
pstr = (char **)(bignum_digits(obj)[0]);
}
else {
char *tmp = NULL;
int len = 0;
tmp = get_string_data(obj, "om_toCString", &len);
tmp[len] = '\0';
pstr = (char **)malloc(sizeof(char *));
*pstr = strdup(tmp);
}
return pstr;
}
Lisp_Object
om_fromCString(char **str)
{
Lisp_Object obj;
obj = make_one_word_bignum((int32)str);
return obj;
}
Lisp_Object
om_cStringFromLispString(Lisp_Object lstr)
{
Lisp_Object cstr;
cstr = om_fromCString(om_toCString(lstr));
return cstr;
}
Lisp_Object
om_lispStringFromCString(Lisp_Object cstr)
{
Lisp_Object lstr;
char **pstr = om_toCString(cstr);
lstr = make_string(*pstr);
return lstr;
}
/*
* Local functions for dealing with property lists.
*/
Lisp_Object
om_getLispProperty(Lisp_Object obj, Lisp_Object name)
{
return get(obj, name, C_nil);
}
Lisp_Object
om_setLispProperty(Lisp_Object obj, Lisp_Object name, Lisp_Object val)
{
return putprop(obj, name, val);
}
/*
* Exposed OpenMath Device manipulation functions.
*/
Lisp_Object MS_CDECL
om_openFileDev(Lisp_Object nil, int nargs, ...)
/* Opens a file and creates an OpenMath device for it. The return value is the
* LISP object which wraps the created device. The parameters are:
* fname - string - the name of the file to open.
* fmode - string - the mode, as passed to the fopen routine.
* fenc - string - the OpenMath encoding type of the file.
*/
{
va_list args;
Lisp_Object lname, lmode, lenc;
char *fname, *fmode;
OMencodingType fenc;
FILE *f;
OMdev dev;
int32 len;
Lisp_Object lispDev;
CSL_IGNORE(nil);
/* Unpack the parameters into Lisp_Objects. */
argcheck(nargs, 3, "om_openFileDev");
va_start(args, nargs);
lname = va_arg(args, Lisp_Object);
lmode = va_arg(args, Lisp_Object);
lenc = va_arg(args, Lisp_Object);
va_end(args);
push3(lname, lmode, lenc);
/* Convert the parameters into their C equivalents. */
if (!is_vector(lname) || !(type_of_header(vechdr(lname)) == TYPE_STRING))
return aerror("om_openFileDev");
errexitn(3);
fname = get_string_data(lname, "om_openFileDev", &len);
errexitn(3);
fname[len] = '\0';
if (!is_vector(lmode) || !(type_of_header(vechdr(lmode)) == TYPE_STRING))
return aerror("om_openFileDev");
errexitn(3);
fmode = get_string_data(lmode, "om_openFileDev", &len);
errexitn(3);
fmode[len] = '\0';
if (!is_fixnum(lenc))
return aerror("om_openFileDev");
errexitn(3);
/* This gets OMencodingTypes as an integer then casts it to OMencodingType.
* That may be a bit dodgy... */
fenc = om_toEncodingType(lenc);
pop3(lname, lmode, lenc);
f = fopen(fname, fmode);
if (f == NULL)
return aerror("om_openFileDev: couldn't open named file!");
/* Create an OpenMath device on the given file. */
dev = OMmakeDevice(fenc, OMmakeIOFile(f));
/* Wrap the OpenMath device in a LISP object and return it. */
lispDev = om_fromDev(dev);
return onevalue(lispDev);
}
Lisp_Object
om_openStringDev(Lisp_Object nil, Lisp_Object lstr, Lisp_Object lenc)
/* Creates an OpenMath string device on an existing string. The return value is
* the LISP object which wraps the created device. The parameters are:
* lstr - string - The string to create the device on. This must be a C
string pointer wrapped in a Lisp object.
* lenc - int - The OpenMath encoding type of the string.
*/
{
/* There may be a problem with the OM library directly accessing the string
* data of a Lisp_Object - see if there is a way around that (if it is a
* problem).
*/
char **pstr = NULL;
OMencodingType enc;
OMdev dev;
Lisp_Object ldev;
CSL_IGNORE(nil);
push2(lstr, lenc);
pstr = om_toCString(lstr);
errexitn(2);
enc = om_toEncodingType(lenc);
errexitn(2);
dev = OMmakeDevice(enc, OMmakeIOString(pstr));
ldev = om_fromDev(dev);
pop2(lstr, lenc);
return onevalue(ldev);
}
Lisp_Object
om_closeDev(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
CSL_IGNORE(nil);
push(ldev);
dev = om_toDev(ldev);
errexitn(1);
OMcloseDevice(dev);
pop(ldev);
return lisp_true;
}
Lisp_Object
om_setDevEncoding(Lisp_Object nil, Lisp_Object ldev, Lisp_Object lenc)
{
OMdev dev;
OMencodingType enc;
CSL_IGNORE(nil);
push2(ldev, lenc);
dev = om_toDev(ldev);
if (!dev)
return aerror("om_setDevEncoding: invalid device");
errexitn(2);
if (!is_fixnum(lenc))
return aerror("om_setDevEncoding: invalid encoding");
errexitn(2);
/* This gets OMencodingTypes as an integer then casts it to OMencodingType.
* That may be a bit dodgy... */
enc = om_toEncodingType(lenc);
errexitn(2);
pop2(ldev, lenc);
OMsetDeviceEncoding(dev, enc);
return onevalue(om_fromDev(dev));
}
/*
* Exposed OpenMath Connection manipulation functions.
*/
Lisp_Object
om_makeConn(Lisp_Object nil, Lisp_Object ltimeout)
{
OMconn conn;
int32 timeout;
CSL_IGNORE(nil);
push(ltimeout);
if (!is_fixnum(ltimeout))
return aerror("om_makeConn: timeout value must be a fixnum");
errexitn(1);
timeout = int_of_fixnum(ltimeout);
errexitn(1);
conn = OMmakeConn(timeout);
pop(ltimeout);
return onevalue(om_fromConn(conn));
}
Lisp_Object
om_closeConn(Lisp_Object nil, Lisp_Object lconn)
{
OMconn conn;
OMstatus status;
CSL_IGNORE(nil);
push(lconn);
conn = om_toConn(lconn);
errexitn(1);
if (!conn)
return aerror("om_toConn");
errexitn(1);
pop(lconn);
status = OMconnClose(conn);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_getConnInDev(Lisp_Object nil, Lisp_Object lconn)
{
OMconn conn;
OMdev dev;
CSL_IGNORE(nil);
push(lconn);
conn = om_toConn(lconn);
errexitn(1);
if (!conn)
return aerror("om_toConn");
errexitn(1);
pop(lconn);
dev = OMconnIn(conn);
return onevalue(om_fromDev(dev));
}
Lisp_Object
om_getConnOutDev(Lisp_Object nil, Lisp_Object lconn)
{
OMconn conn;
OMdev dev;
CSL_IGNORE(nil);
push(lconn);
conn = om_toConn(lconn);
errexitn(1);
if (!conn)
return aerror("om_toConn");
errexitn(1);
pop(lconn);
dev = OMconnOut(conn);
return om_fromDev(dev);
}
/*
* Exposed OpenMath client/server functions.
*/
Lisp_Object MS_CDECL
om_connectTCP(Lisp_Object nil, int nargs, ...)
{
va_list args;
Lisp_Object lconn, lhost, lport;
OMconn conn;
char *host = NULL;
int32 hostlen;
int32 port;
OMstatus status;
CSL_IGNORE(nil);
/* Unpack the parameters into Lisp_Objects. */
argcheck(nargs, 3, "om_connectTCP");
va_start(args, nargs);
lconn = va_arg(args, Lisp_Object);
lhost = va_arg(args, Lisp_Object);
lport = va_arg(args, Lisp_Object);
va_end(args);
push3(lconn, lhost, lport);
/* Convert the parameters into their C equivalents. */
conn = om_toConn(lconn);
errexitn(3);
if (!conn)
return aerror("om_toConn");
errexitn(3);
if (!stringp(lhost))
return aerror("om_connectTCP: host name must be a string");
errexitn(3);
host = get_string_data(lhost, "om_putString", &hostlen);
errexitn(3);
if (host != NULL)
host[hostlen] = '\0';
if (!is_fixnum(lport))
return aerror("om_connectTCP: port number must be a fixnum");
errexitn(3);
port = int_of_fixnum(lport);
errexitn(3);
pop3(lconn, lhost, lport);
status = OMconnTCP(conn, host, port);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_bindTCP(Lisp_Object nil, Lisp_Object lconn, Lisp_Object lport)
{
OMconn conn;
int32 port;
OMstatus status;
CSL_IGNORE(nil);
push2(lconn, lport);
conn = om_toConn(lconn);
errexitn(2);
if (!conn)
return aerror("om_toConn");
errexitn(2);
if (!is_fixnum(lport))
return aerror("om_bindTCP: port number must be a fixnum");
errexitn(2);
port = int_of_fixnum(lport);
errexitn(2);
pop2(lconn, lport);
status = OMbindTCP(conn, port);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
/*
* Exposed OpenMath Device output functions.
*/
Lisp_Object
om_putApp(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputApp(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putEndApp(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputEndApp(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putAtp(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputAtp(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putEndAtp(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputEndAtp(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putAttr(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputAttr(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putEndAttr(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputEndAttr(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putBind(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputBind(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putEndBind(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputEndBind(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putBVar(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputBVar(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putEndBVar(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputEndBVar(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putError(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputError(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putEndError(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputEndError(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putObject(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputObject(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putEndObject(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMputEndObject(dev);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putInt(Lisp_Object nil, Lisp_Object ldev, Lisp_Object val)
/* This routine expects val to be a Lisp integer of some sort.
* The decision of whether to put it as an int32 or a bigint
* will be made by this routine.
*/
{
OMdev dev;
OMstatus status;
int size, sign;
char *data;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
if (!is_number(val) || is_float(val))
return aerror("om_putInt");
if (is_fixnum(val)) {
int32 ival = int_of_fixnum(val);
status = OMputInt32(dev, ival);
}
else {
data = om_toBigNumStr(val);
size = strlen(data);
sign = minusp(val) ? -1 : 1;
status = OMputBigInt(dev, data, size, sign, OMbigIntBase16);
free(data);
}
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putFloat(Lisp_Object nil, Lisp_Object ldev, Lisp_Object val)
/* This routine expects val to be a real-valued number of some
* sort (this includes floats, rationals, etc.) and puts it
* out as an IEEE 64-bit floating point number.
*/
{
/* TODO: check this generates correct output for all real numbers. */
OMdev dev;
OMstatus status;
double fval;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
if (!is_number(val))
return aerror("om_putFloat");
fval = float_of_number(val);
/* err_printf("[om-putFloat] fval = %.30lf\n", fval); */
status = OMputFloat64(dev, &fval);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
Lisp_Object
om_putByteArray(Lisp_Object nil, Lisp_Object ldev, Lisp_Object val)
/* This routine expects val to be a Lisp vector of 8-bit values.
*/
{
OMdev dev;
OMstatus status;
int32 len;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
if (!is_vector(val) || !(type_of_header(vechdr(val)) == TYPE_VEC8))
return aerror("om_toDev");
/* Get the length of the array. */
len = length_of_header(val) - 4; /* is this correct??? */
/* Write out the array data. */
status = OMputByteArray(dev, ((char *)val - TAG_VECTOR + 4), len);
if (status != OMsuccess) return om_error(status);
else return lisp_true;
}
Lisp_Object
om_putVar(Lisp_Object nil, Lisp_Object ldev, Lisp_Object val)
/* This routine expects val to be a symbol.
*/
{
OMdev dev;
OMstatus status;
char *name;
int32 len;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
if (!is_symbol(val))
return aerror("om_putVar");
/* Do I need to free the memory for name myself? I don't know... */
name = get_string_data(val, "om_putVar", &len);
if (name == NULL)
return om_error(OMinternalError);
else {
status = OMputVarN(dev, name, len);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
}
Lisp_Object
om_putString(Lisp_Object nil, Lisp_Object ldev, Lisp_Object val)
/* This routine expects val to be a Lisp string.
*/
{
OMdev dev;
OMstatus status;
char *name;
int32 len;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
if (!is_vector(val) || !(type_of_header(vechdr(val)) == TYPE_STRING))
return aerror("om_putString");
/* Do I need to free the memory for name myself? I don't know... */
name = get_string_data(val, "om_putString", &len);
if (name == NULL)
return om_error(OMinternalError);
else {
status = OMputStringN(dev, name, len);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
}
Lisp_Object
om_putSymbol(Lisp_Object nil, Lisp_Object ldev, Lisp_Object val)
/* This routine expects val to be a cons cell where the first element is the
* name of the content dictionary and the second (and final) element is the
* name of the symbol.
*/
{
Lisp_Object cdObj, nameObj;
/* Check that the value passed in is in the correct format. */
if (!is_cons(val))
return aerror("om_putSymbol");
/* Get the cd and name properties (checking that they are set). */
cdObj = qcar(val);
if (cdObj == nil)
return aerror("om_putSymbol: The cd property was not set");
nameObj = qcar(qcdr(val));
if (nameObj == nil)
return aerror("om_putSymbol: The name property was not set");
/* Invoke the verbose form of the putSymbol routine to output the data. */
return om_putSymbol2(nil, 3, ldev, cdObj, nameObj);
}
Lisp_Object MS_CDECL
om_putSymbol2(Lisp_Object nil, int nargs, ...)
/*
* A different form of putSymbol, where the cd and symbol names are given as strings.
* The parameters are: (om-putSymbol omdevice "cdname" "symbolname")
*/
{
va_list args;
Lisp_Object ldev;
Lisp_Object lcd, lname;
OMdev dev;
char *cd, *name;
int32 cdLen, nameLen;
OMstatus status;
/* Get the arguments from the arglist. */
argcheck(nargs, 3, "om_putSymbol2");
va_start(args, nargs);
ldev = va_arg(args, Lisp_Object);
lcd = va_arg(args, Lisp_Object);
lname = va_arg(args, Lisp_Object);
va_end(args);
/* err_printf("[om_putSymbol2] about to convert params to C equivalents...\n"); */
/* Convert the parameters into their C equivalents. */
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
if (!is_vector(lcd) || !(type_of_header(vechdr(lcd)) == TYPE_STRING))
return aerror("om_putSymbol2");
cd = get_string_data(lcd, "om_putSymbol2", &cdLen);
if (cd == NULL) {
status = OMinternalError;
return om_error(status);
}
/* err_printf("[om_putSymbol2] converted cd name (%s)\n", cd); */
if (!is_vector(lname) || !(type_of_header(vechdr(lname)) == TYPE_STRING))
return aerror("om_putSymbol2");
name = get_string_data(lname, "om_putSymbol2", &nameLen);
if (name == NULL) {
status = OMinternalError;
return om_error(status);
}
/* err_printf("[om_putSymbol2] converted symbol name (%s)\n", name); */
/* Now write out the symbol. */
status = OMputSymbolN(dev, cd, cdLen, name, nameLen);
if (status != OMsuccess)
return om_error(status);
else
return lisp_true;
}
/*
* OpenMath input routines.
*/
Lisp_Object
om_getApp(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetApp(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMA");
}
Lisp_Object
om_getEndApp(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetEndApp(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMA-END");
}
Lisp_Object
om_getAtp(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetAtp(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMATP");
}
Lisp_Object
om_getEndAtp(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetEndAtp(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMATP-END");
}
Lisp_Object
om_getAttr(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetAttr(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMATTR");
}
Lisp_Object
om_getEndAttr(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetEndAttr(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMATTR-END");
}
Lisp_Object
om_getBind(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetBind(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMBIND");
}
Lisp_Object
om_getEndBind(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetEndBind(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMBIND-END");
}
Lisp_Object
om_getBVar(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetBVar(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMBVAR");
}
Lisp_Object
om_getEndBVar(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetEndBVar(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMBVAR-END");
}
Lisp_Object
om_getError(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetError(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OME");
}
Lisp_Object
om_getEndError(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetEndError(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OME-END");
}
Lisp_Object
om_getObject(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetObject(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMOBJ");
}
Lisp_Object
om_getEndObject(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetEndObject(dev);
if (status != OMsuccess)
return om_error(status);
else
return make_undefined_symbol("OMOBJ-END");
}
Lisp_Object
om_getInt(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
OMtokenType ttype;
Lisp_Object obj;
dev = om_toDev(ldev);
if (!dev)
return aerror("om_toDev");
status = OMgetType(dev, &ttype);
if (status == OMsuccess) {
switch (ttype) {
case OMtokenInt32:
{
int32 val;
status = OMgetInt32(dev, &val);
if (status == OMsuccess) {
/* If none of the top 4 bits are set, we can make this a
* fixnum */
/* On second thoughts, the top bit is the sign, and the <<
* operation is sign preserving (I believe), so we only
* need to check bits 28-30. */
if ((val & 0x70000000) == 0)
obj = fixnum_of_int(val);
else
obj = make_one_word_bignum(val);
}
break;
}
case OMtokenBigInt:
{
/* TODO: This is broken. Fix it. */
char *data;
int len, sign;
OMbigIntType fmt;
status = OMgetBigInt(dev, &data, &len, &sign, &fmt);
if (status == OMsuccess)
obj = om_fromBigNumStr(data, len, sign, fmt);
free(data);
break;
}
default:
{
obj = om_error(OMmalformedInput);
break;
}
}
}
else obj = om_error(status);
return onevalue(obj);
}
Lisp_Object
om_getFloat(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
OMtokenType ttype;
double val;
dev = om_toDev(ldev);
if (dev == NULL)
return aerror("om_toDev");
status = OMgetType(dev, &ttype);
if (status == OMsuccess) {
status = OMgetFloat64(dev, &val);
if (status == OMsuccess) {
/* err_printf("[om_getFloat] fval = %.30lf\n", val); */
return make_boxfloat(val, TYPE_DOUBLE_FLOAT);
}
else
return om_error(status);
}
else return om_error(status);
}
Lisp_Object
om_getByteArray(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
int len;
Lisp_Object obj;
dev = om_toDev(ldev);
if (dev == NULL)
return aerror("om_toDev");
status = OMgetLength(dev, &len);
if (status != OMsuccess)
return om_error(status);
else {
/* I hope this is right... */
obj = getvector(TAG_VECTOR, TYPE_VEC8, len + 4);
status = OMgetByteArrayN(dev, ((char *)obj - TAG_VECTOR + 4), len);
if (status != OMsuccess)
return om_error(status);
else
return obj;
}
}
Lisp_Object
om_getVar(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
char *var;
Lisp_Object obj;
dev = om_toDev(ldev);
if (dev == NULL)
return aerror("om_toDev");
status = OMgetVar(dev, &var);
if (status != OMsuccess)
return om_error(status);
else {
obj = make_symbol(var, 2, /* do not convert name to upper case */
undefined1, undefined2, undefinedn);
free(var);
return obj;
}
}
Lisp_Object
om_getString(Lisp_Object nil, Lisp_Object ldev)
{
OMdev dev;
OMstatus status;
char *str;
Lisp_Object obj;
dev = om_toDev(ldev);
if (dev == NULL)
return aerror("om_toDev");
status = OMgetString(dev, &str);
if (status != OMsuccess)
return om_error(status);
else {
obj = make_string(str);
free(str);
return obj;
}
}
Lisp_Object
om_getSymbol(Lisp_Object nil, Lisp_Object ldev)
/* This returns the Lisp symbol OMS, with a cd property and a name property set
* to appropriate string values.
*/
{
OMdev dev;
OMstatus status;
char *cd, *name;
int cdLen, nameLen;
Lisp_Object cdstr, namestr, obj;
CSL_IGNORE(nil);
push(ldev);
dev = om_toDev(ldev);
errexitn(1);
if (dev == NULL)
return aerror("om_toDev");
errexitn(1);
pop(ldev);
status = OMgetSymbolLength(dev, &cdLen, &nameLen);
if (status != OMsuccess)
return om_error(status);
cd = (char *)malloc(sizeof(char) * (cdLen + 1));
name = (char *)malloc(sizeof(char) * (nameLen + 1));
if (cd == NULL || name == NULL) {
if (cd != NULL) free(cd);
else if (name != NULL) free(name);
return om_error(OMinternalError);
}
cd[cdLen] = '\0';
name[nameLen] = '\0';
status = OMgetSymbolN(dev, cd, cdLen, name, nameLen);
if (status != OMsuccess)
obj = om_error(status);
else {
cdstr = make_string(cd);
namestr = make_string(name);
/* FIXME: is this needed? push2(cdstr, namestr);*/
obj = cons(cdstr, cons(namestr, C_nil));
}
free(cd);
free(name);
/*return onevalue(obj);*/
return obj;
}
#define om_errmsg0(msg) \
err_printf("[om_getType] %s\n", msg)
#define om_errmsg1(msg,a1) \
err_printf("[om_getType] %s%s\n", msg,a1)
#define om_errmsg2(msg,a1,a2) \
err_printf("[om_getType] %s%s%s\n", msg,a1,a2)
Lisp_Object
om_getType(Lisp_Object nil, Lisp_Object ldev)
{
static char *typenames[] = {
"OMtokenApp", "OMtokenEndApp",
"OMtokenAtp", "OMtokenEndAtp",
"OMtokenAttr", "OMtokenEndAttr",
"OMtokenBind", "OMtokenEndBind",
"OMtokenBVar", "OMtokenEndBVar",
"OMtokenError", "OMtokenEndError",
"OMtokenObject", "OMtokenEndObject",
"OMtokenInt",
"OMtokenFloat",
"OMtokenByteArray",
"OMtokenVar",
"OMtokenString",
"OMtokenSymbol"
};
OMdev dev;
OMstatus status;
OMtokenType ttype;
char *typename;
Lisp_Object obj;
dev = om_toDev(ldev);
if (dev == NULL)
return aerror("om_toDev");
status = OMgetType(dev, &ttype);
if (status != OMsuccess)
return om_error(status);
else {
switch (ttype) {
case OMtokenApp: typename = typenames[0]; break;
case OMtokenEndApp: typename = typenames[1]; break;
case OMtokenAtp: typename = typenames[2]; break;
case OMtokenEndAtp: typename = typenames[3]; break;
case OMtokenAttr: typename = typenames[4]; break;
case OMtokenEndAttr: typename = typenames[5]; break;
case OMtokenBind: typename = typenames[6]; break;
case OMtokenEndBind: typename = typenames[7]; break;
case OMtokenBVar: typename = typenames[8]; break;
case OMtokenEndBVar: typename = typenames[9]; break;
case OMtokenError: typename = typenames[10]; break;
case OMtokenEndError: typename = typenames[11]; break;
case OMtokenObject: typename = typenames[12]; break;
case OMtokenEndObject: typename = typenames[13]; break;
case OMtokenInt32: typename = typenames[14]; break;
case OMtokenBigInt: typename = typenames[14]; break;
case OMtokenFloat64: typename = typenames[15]; break;
case OMtokenByteArray: typename = typenames[16]; break;
case OMtokenVar: typename = typenames[17]; break;
case OMtokenString: typename = typenames[18]; break;
case OMtokenSymbol: typename = typenames[19]; break;
}
obj = make_undefined_symbol(typename);
return obj;
}
}
Lisp_Object
om_stringToStringPtr(Lisp_Object nil, Lisp_Object lstr)
{
return om_cStringFromLispString(lstr);
}
Lisp_Object
om_stringPtrToString(Lisp_Object nil, Lisp_Object lpstr)
{
return om_lispStringFromCString(lpstr);
}
setup_type const om_setup[] = {
/* LISP Name */ /* Unary */ /* Binary */ /* Nary */
{"om-openFileDev", wrong_no_3a, wrong_no_3b, om_openFileDev},
{"om-openStringDev", too_few_2, om_openStringDev, wrong_no_2},
{"om-closeDev", om_closeDev, too_many_1, wrong_no_1},
{"om-setDevEncoding", too_few_2, om_setDevEncoding, wrong_no_2},
{"om-makeConn", om_makeConn, too_many_1, wrong_no_1},
{"om-closeConn", om_closeConn, too_many_1, wrong_no_1},
{"om-getConnInDev", om_getConnInDev, too_many_1, wrong_no_1},
{"om-getConnOutDev", om_getConnOutDev, too_many_1, wrong_no_1},
{"om-connectTCP", wrong_no_3a, wrong_no_3b, om_connectTCP},
{"om-bindTCP", too_few_2, om_bindTCP, wrong_no_2},
{"om-putApp", om_putApp, too_many_1, wrong_no_1},
{"om-putEndApp", om_putEndApp, too_many_1, wrong_no_1},
{"om-putAtp", om_putAtp, too_many_1, wrong_no_1},
{"om-putEndAtp", om_putEndAtp, too_many_1, wrong_no_1},
{"om-putAttr", om_putAttr, too_many_1, wrong_no_1},
{"om-putEndAttr", om_putEndAttr, too_many_1, wrong_no_1},
{"om-putBind", om_putBind, too_many_1, wrong_no_1},
{"om-putEndBind", om_putEndBind, too_many_1, wrong_no_1},
{"om-putBVar", om_putBVar, too_many_1, wrong_no_1},
{"om-putEndBVar", om_putEndBVar, too_many_1, wrong_no_1},
{"om-putError", om_putError, too_many_1, wrong_no_1},
{"om-putEndError", om_putEndError, too_many_1, wrong_no_1},
{"om-putObject", om_putObject, too_many_1, wrong_no_1},
{"om-putEndObject", om_putEndObject, too_many_1, wrong_no_1},
{"om-putInt", too_few_2, om_putInt, wrong_no_2},
{"om-putFloat", too_few_2, om_putFloat, wrong_no_2},
{"om-putByteArray", too_few_2, om_putByteArray, wrong_no_2},
{"om-putVar", too_few_2, om_putVar, wrong_no_2},
{"om-putString", too_few_2, om_putString, wrong_no_2},
{"om-putSymbol", too_few_2, om_putSymbol, om_putSymbol2},
{"om-getApp", om_getApp, too_many_1, wrong_no_1},
{"om-getEndApp", om_getEndApp, too_many_1, wrong_no_1},
{"om-getAtp", om_getAtp, too_many_1, wrong_no_1},
{"om-getEndAtp", om_getEndAtp, too_many_1, wrong_no_1},
{"om-getAttr", om_getAttr, too_many_1, wrong_no_1},
{"om-getEndAttr", om_getEndAttr, too_many_1, wrong_no_1},
{"om-getBind", om_getBind, too_many_1, wrong_no_1},
{"om-getEndBind", om_getEndBind, too_many_1, wrong_no_1},
{"om-getBVar", om_getBVar, too_many_1, wrong_no_1},
{"om-getEndBVar", om_getEndBVar, too_many_1, wrong_no_1},
{"om-getError", om_getError, too_many_1, wrong_no_1},
{"om-getendError", om_getEndError, too_many_1, wrong_no_1},
{"om-getObject", om_getObject, too_many_1, wrong_no_1},
{"om-getEndObject", om_getEndObject, too_many_1, wrong_no_1},
{"om-getInt", om_getInt, too_many_1, wrong_no_1},
{"om-getFloat", om_getFloat, too_many_1, wrong_no_1},
{"om-getByteArray", om_getByteArray, too_many_1, wrong_no_1},
{"om-getVar", om_getVar, too_many_1, wrong_no_1},
{"om-getString", om_getString, too_many_1, wrong_no_1},
{"om-getSymbol", om_getSymbol, too_many_1, wrong_no_1},
{"om-getType", om_getType, too_many_1, wrong_no_1},
{"om-stringToStringPtr", om_stringToStringPtr, too_many_1, wrong_no_1},
{"om-stringPtrToString", om_stringPtrToString, too_many_1, wrong_no_1},
{NULL, 0, 0, 0}
};
#endif /* OPENMATH */