home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / xdrfuns.c < prev   
Encoding:
C/C++ Source or Header  |  1991-05-14  |  2.7 KB  |  113 lines
  1.  
  2. #ifdef HAVE_XDR
  3.  
  4. #ifdef AIX3
  5. #include <sys/select.h>
  6. #endif
  7. #include <rpc/rpc.h>
  8.  
  9. extern short aet_sizes[];
  10. object
  11. siGxdr_open(f)
  12.      object f;
  13. { XDR *xdrs;
  14.   object ar= alloc_simple_string(sizeof(XDR));
  15.   array_allocself(ar,1,0);
  16.   xdrs= (XDR *) ar->a.a_self;
  17.   if (f->sm.sm_fp == 0) FEerror("stream not ok for xdr io");
  18.   xdrstdio_create(xdrs, f->sm.sm_fp,
  19.           (f->sm.sm_mode == smm_input ?  XDR_DECODE :
  20.            f->sm.sm_mode == smm_output ?  XDR_ENCODE :
  21.            FEerror("stream not input or output")))
  22.            ;
  23.   return ar;
  24. }
  25.  
  26. object
  27. siGxdr_write(str,elt)
  28.      object str,elt;
  29. { XDR *xdrp= (XDR *) str->ust.ust_self;
  30.  
  31.   switch (type_of(elt))
  32.    { case t_fixnum:
  33.        if(!xdr_long(xdrp,&fix(elt))) goto error;
  34.         return elt;
  35.      case t_longfloat:
  36.        if(!xdr_double(xdrp,&lf(elt))) goto error;
  37.         return elt;
  38.      case t_shortfloat:
  39.        if(!xdr_float(xdrp,&sf(elt))) goto error;
  40.         return elt;
  41.      case t_vector:
  42.        if(!xdr_array(xdrp,&elt->v.v_self,
  43.          &elt->v.v_fillp,
  44.          elt->v.v_dim,
  45.          aet_sizes[elt->v.v_elttype],
  46.          (elt->v.v_elttype == aet_lf ? xdr_double :
  47.           elt->v.v_elttype == aet_sf ? xdr_float :
  48.           elt->v.v_elttype == aet_fix ? xdr_int :
  49.           elt->v.v_elttype == aet_short ? xdr_short :
  50.           (FEerror("unsupported xdr size",0),xdr_short))))
  51.      goto error ;
  52.        return elt;
  53.      default:
  54.        FEerror("unsupported xdr ~a",1,elt);
  55.      }
  56.   return elt;
  57.  error:
  58.   FEerror("bad xdr read");
  59.      }
  60.  
  61. object
  62. siGxdr_read(str,elt)
  63.           object str,elt;
  64. { XDR *xdrp= (XDR *) str->ust.ust_self;
  65.   switch (type_of(elt))
  66.    { case t_fixnum:
  67.        {int l;
  68.     
  69.        if(!xdr_long(xdrp,&l)) goto error;
  70.     return make_fixnum(l);}
  71.        break;
  72.      case t_longfloat:
  73.        { double x;
  74.        if(!xdr_double(xdrp,&x)) goto error;
  75.         return make_longfloat(x);}
  76.      case t_shortfloat:
  77.        { float x;
  78.        if(!xdr_float(xdrp,&x)) goto error;
  79.         return make_shortfloat(x);}
  80.      case t_vector:
  81.       if(! xdr_array(xdrp,&elt->v.v_self,
  82.          &elt->v.v_fillp,
  83.          elt->v.v_dim,
  84.          aet_sizes[elt->v.v_elttype],
  85.          (elt->v.v_elttype == aet_lf ? xdr_double :
  86.           elt->v.v_elttype == aet_sf ? xdr_float :
  87.           elt->v.v_elttype == aet_fix ? xdr_int :
  88.           elt->v.v_elttype == aet_short ? xdr_short :
  89.           (FEerror("unsupported xdr size",0),xdr_short))))
  90.     goto error;
  91.        return elt;
  92.      default:
  93.        FEerror("unsupported xdr ~a",1,elt);
  94.      }
  95.      error:
  96.   FEerror("bad xdr read");
  97.   return elt;
  98. }
  99.  
  100. init_xdrfuns()
  101. { make_si_sfun("XDR-WRITE",siGxdr_write,
  102.            ARGTYPE2(f_object,f_object)|RESTYPE(f_object));
  103.  
  104.   make_si_sfun("XDR-READ",siGxdr_read,
  105.            ARGTYPE2(f_object,f_object)|RESTYPE(f_object));
  106.   make_si_sfun("XDR-OPEN",siGxdr_open,
  107.            ARGTYPE1(f_object)|RESTYPE(f_object));
  108.   
  109. }
  110. #else
  111. init_xdrfuns(){;}
  112. #endif     
  113.