Artifact e98295695bb90c9b88cf3ae47de2b3f7a1e4c2f6963fffbd4e5a0fff091b7826:
- Executable file
r36/cslbase/xdrfuns.c
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 6564) [annotate] [blame] [check-ins using] [more...]
/* xdrfuns.c Copyright (C) 1995 NAG Ltd */ /* * Functions to support reading and writing of objects in XDR format. * * Version 1.0 September 1995 * * Author: Mike Dewar * */ /* Signature: 4695c817 27-Jan-1997 */ #include <stdio.h> #ifdef AIX3 #include <sys/select.h> #endif /* * What I really mean here is ifdef(UNIX), but we don't know that until * machine.h is included. To simplify matters I'll just check to see if * we are using the Watcom compiler. Including machine.h earlier causes * some problems on the RS6000. */ #ifndef __WATCOMC__ #include <rpc/rpc.h> #endif #include <stdarg.h> #include <ctype.h> /* These are defined by the rpc code on the alpha */ #define int32 csl_int32 #define int64 csl_int64 #include "machine.h" #include "tags.h" #include "cslerror.h" #include "externs.h" #include "entries.h" #include "stream.h" #include "arith.h" #ifdef UNIX Lisp_Object LxdrOpen(Lisp_Object nil, Lisp_Object f, Lisp_Object d) { XDR xdrs; Lisp_Object lxdr; /* * First argument must be an open stream. Since CCL streams are all * bi-directional we get the intended direction from the second argument. */ if (!is_stream(f)) return aerror("xdrOpen"); xdrstdio_create(&xdrs,stream_file(f),(d == lisp_true)?XDR_ENCODE:XDR_DECODE); /* Copy the XDR structure into a string to avoid alignment problems. */ lxdr = Lsmkvect(nil,fixnum_of_int(sizeof(XDR))); memcpy(&celt(lxdr,0),&xdrs,sizeof(XDR)); return onevalue(lxdr); } #define XW(x,u) ( (!x) ? aerror1("Bad XDR write for: ",u) : u ) Lisp_Object LxdrWrite(Lisp_Object nil, Lisp_Object lxdr,Lisp_Object u) { XDR xdrs; /* Copy the XDR structure out of a CCL string. */ memcpy(&xdrs,&celt(lxdr,0),sizeof(XDR)); /* * We include the bignum case since fixnums in CCL are 28 bits and we would * like to support 32 bit integers here. */ if (is_fixnum(u) ) { int32 temp = int_of_fixnum(u); return XW(xdr_int(&xdrs,&temp), u); } else if (is_float(u) ) { double temp = float_of_number(u); return XW(xdr_double(&xdrs,&temp), u); } else if (is_numbers(u) && is_bignum(u) ) { int32 temp=thirty_two_bits(u); return XW(xdr_int(&xdrs,&temp), u); } else if (is_vector(u) && type_of_header(vechdr(u)) == TYPE_STRING) { int32 len = length_of_header(vechdr(u))-4; char *temp=&celt(u,0); return XW(xdr_string(&xdrs,&temp,len),u); } else if (is_vector(u) ) { int32 count, len = thirty_two_bits(Llength(nil,u)); Lisp_Object v = elt(u,0); /* * Mimic the way that xdr_array works by writing the length of the * array first. */ if (!xdr_int(&xdrs,&len)) aerror1("XDR Error writing length of:",u); /* * Although Common Lisp Vectors are not homogeneous, C vectors are, * so we will assume that u is homogeneous and only test the type * of the first element. */ if (is_float(v) ) { double temp; for (count=0 ; count < len ; ++count) { temp = float_of_number(elt(u,count)); if (!xdr_double(&xdrs,&temp)) aerror1("Bad XDR write for Double-Float vector element: ",v); } return(u); } else if (is_fixnum(v) || ( is_numbers(v) && is_bignum(v) ) ) { int32 temp; for (count=0 ; count < len ; ++count) { temp = thirty_two_bits(elt(u,count)); if (!xdr_int(&xdrs,&temp)) aerror1("Bad XDR write for integer vector element: ",v); } return(u); } else aerror1("XDR cannot handle a vector containing:",v); } else aerror1("XDR cannot handle:",u); } /* This checks a 32 bit integer's value and returns it as either a fixnum or a bignum. */ #define int2ccl(i) (i > -268435455 && i < 268435456) ? fixnum_of_int(i) : make_one_word_bignum(i) Lisp_Object LxdrRead(Lisp_Object nil, Lisp_Object lxdr,Lisp_Object u) { XDR xdrs; int temp; /* Copy the XDR structure out of a CCL string. */ memcpy(&xdrs,&celt(lxdr,0),sizeof(XDR)); if (is_fixnum(u) || (is_numbers(u) && is_bignum(u) ) ) { int32 temp; if (!xdr_int(&xdrs,&temp)) aerror("Integer XDR read"); return onevalue(int2ccl(temp)); } else if (is_float(u) ) { double temp; if (!xdr_double(&xdrs,&temp)) aerror("Double-Float XDR read"); return onevalue(make_boxfloat(temp,TYPE_DOUBLE_FLOAT)); } else if (is_vector(u) && type_of_header(vechdr(u)) == TYPE_STRING) { char *temp=NULL; /* Value for maximum length of a string is fairly arbitrary! */ if (!xdr_string(&xdrs,&temp,16777216)) aerror("String XDR read"); return onevalue(make_string(temp)); } else if (is_vector(u) ) { int32 count, len; Lisp_Object new, v = elt(u,0); /* xdr_array writes the length of the array first. */ if (!xdr_int(&xdrs,&len)) aerror1("XDR Error reading length of:",u); /* Create the new vector */ new = getvector(TAG_VECTOR, TYPE_SIMPLE_VEC, 4*len+4); /* vectors must pad to an even number of words */ if ((len & 1) == 0) elt(new,len) = nil; /* * Although Common Lisp Vectors are not homogeneous, C vectors are, * so we will assume that u is homogeneous and only test the type * of the first element. */ if (is_float(v) ) { double temp; for (count=0 ; count < len ; ++count) { if (!xdr_double(&xdrs,&temp)) aerror("Double-Float vector XDR read"); elt(new,count) = make_boxfloat(temp,TYPE_DOUBLE_FLOAT); } } else if ( is_fixnum(v) || ( is_numbers(v) && is_bignum(v) )) { int32 temp; for (count=0 ; count < len ; ++count) { if (!xdr_int(&xdrs,&temp)) aerror("Integer vector XDR read"); elt(new,count) = int2ccl(temp); } } else aerror1("XDR cannot handle a vector containing:",v); return onevalue(new); } else aerror1("XDR cannot handle:",u); } #else /* UNIX */ Lisp_Object LxdrOpen(Lisp_Object nil, Lisp_Object f, Lisp_Object d) { aerror("Attempt to call xdr-open on non-Unix platform"); return nil; } Lisp_Object LxdrWrite(Lisp_Object nil, Lisp_Object lxdr, Lisp_Object u) { aerror("Attempt to call xdr-write on non-Unix platform"); return nil; } Lisp_Object LxdrRead(Lisp_Object nil, Lisp_Object lxdr, Lisp_Object u) { aerror("Attempt to call xdr-read on non-Unix platform"); return nil; } #endif /* UNIX */ setup_type const xdr_setup[] = { {"xdr-open", too_few_2, LxdrOpen, wrong_no_2}, {"xdr-write", too_few_2, LxdrWrite, wrong_no_2}, {"xdr-read", too_few_2, LxdrRead, wrong_no_2}, {NULL, 0, 0, 0} };