home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / AddOns / obread.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-07-23  |  9.5 KB  |  420 lines
  1. /*
  2.   * generic object reading and writing
  3.   *
  4.   * Assumptions
  5.   *   Floating point is the same on all interesting machines...
  6.   *   Overflow never happens...
  7.   *   Also ints are the same everywhere: This must be changed soon!
  8.   * Lisp Functions:
  9.   *   make-obj-reader
  10.   *     make a new instance of the default reader
  11.   *
  12.   *   add-reader (reader id function)
  13.   *     function should take a reader function and a position as arguments
  14.   *
  15.   *   add-writer (reader id-num class function)   
  16.   *     function should take a writer function and a position as arguments 
  17.   *   
  18.   * C Functions:
  19.   *   LispObject read_obj(buf,reader)
  20.   */
  21.  
  22.  
  23. #include <stdio.h>
  24. #include "defs.h"
  25. #include "structs.h"
  26. #include "funcalls.h"
  27. #include "global.h"
  28. #include "error.h"
  29. #include "allocate.h"
  30. #include "class.h"
  31. #include "modboot.h"
  32. #include "bootstrap.h"
  33. #include "allocate.h"
  34. #include "ngenerics.h"
  35. #include "calls.h"
  36.  
  37. #include "obread.h"
  38. #include "obread_p.h"
  39.  
  40. /* lose this sometime... */
  41. #define OBJECTIFY(ptr) (allocate_integer(stacktop,(int) ptr))
  42.  
  43. /* Need this to find writers in a pseudo-generic way */
  44.  
  45. LispObject lookup_by_cpl(LispObject *stacktop,LispObject tbl, LispObject class)
  46. {
  47.   LispObject res;
  48.  
  49.   res=EUCALL_2(generic_apply_1,tbl,class);
  50.        
  51.   return res;
  52. }
  53.  
  54. EUFUN_1( Fn_make_obj_reader,gf)
  55. {
  56.   LispObject ans,tmp;
  57.   
  58.   ans = (LispObject) allocate_vector(stacktop,2);
  59.   STACK_TMP(ans);
  60.   tmp = allocate_vector(stacktop,MAX_ID + 1);
  61.   UNSTACK_TMP(ans);
  62.   vref(ans,0)=tmp;
  63.   vref(ans,1) = ARG_0(stackbase);
  64.  
  65.   return ans;
  66. }
  67. EUFUN_CLOSE
  68.  
  69. static EUFUN_3( Fn_add_reader, reader, id, fn)
  70. {
  71.   GET_READER(reader,intval(id)) = fn;
  72.   return lisptrue;
  73. }
  74. EUFUN_CLOSE
  75.  
  76. static EUFUN_4( Fn_add_writer, reader, class, 
  77.            id,  fn)
  78. {
  79.   LispObject xx;
  80.   if (!is_function(fn))
  81.     CallError(stacktop,"add-writer: type error",fn,NONCONTINUABLE);
  82.  
  83.   if(!is_fixnum(id))
  84.     CallError(stacktop,"add-writer: type error",id,NONCONTINUABLE);
  85.       
  86.   xx=MAKE_WRITER(id,fn);
  87.   reader=ARG_0(stackbase);
  88.   class=ARG_1(stackbase);
  89.   SET_WRITER(reader,class,xx);
  90.   return nil;
  91. }
  92. EUFUN_CLOSE
  93.  
  94. static EUFUN_2( Fn_read_next, obj, reader)
  95. {
  96.   LispObject ans;
  97.  
  98.   ans = read_obj(stacktop,(unsigned char **)(intval(obj)),reader);
  99.   return ans;
  100. }
  101. EUFUN_CLOSE
  102.  
  103. static EUFUN_3( Fn_write_next, 
  104.            thing, 
  105.            posn,
  106.            reader)
  107. {
  108.   write_obj(stacktop,thing, (unsigned char **) (intval(posn)),reader);
  109.   return nil;
  110. }
  111. EUFUN_CLOSE
  112.  
  113. LispObject read_obj(LispObject *stacktop,unsigned char **p_ptr, LispObject reader)
  114. {
  115.   static LispObject read_cons_object(LispObject *,unsigned char **p_ptr, LispObject reader);
  116.   static LispObject read_vector_object(LispObject *,unsigned char **p_ptr, LispObject reader);
  117.   extern LispObject get_symbol_by_copying(LispObject *,char *);
  118.  
  119.   double fl;
  120.   int n;
  121.   unsigned char *tmp;
  122.   
  123.   EUBUG(printf("read: looking at: %d\n",**p_ptr));
  124.   if (**p_ptr < FIRST_USER_ID)
  125.     {
  126.       switch(**p_ptr)
  127.     {
  128.     case READ_FLOAT:
  129.       ++ (*p_ptr);
  130.       bcopy(*p_ptr, (char *) &fl, sizeof(double));
  131.       *p_ptr = *p_ptr + sizeof(double);
  132.       return(allocate_float(stacktop,fl));
  133.       break;
  134.  
  135.     case READ_INT:
  136.       ++(*p_ptr);
  137.       bcopy(*p_ptr, (char *) &n, sizeof(int));
  138.       *p_ptr = *p_ptr + sizeof(int);
  139.       return (allocate_integer(stacktop,n));
  140.       break;
  141.  
  142.     case READ_STRING:
  143.       ++(*p_ptr); 
  144.       n = strlen((*p_ptr));
  145.       tmp = *p_ptr;
  146.       /* add 1 for the 0 character */
  147.       (*p_ptr) += n + 1;
  148.       return(allocate_string(stacktop,(char *)tmp,n));
  149.       break;
  150.  
  151.     case READ_SYMBOL:
  152.       ++(*p_ptr); 
  153.       n = strlen(*p_ptr);    /*  Need copy, o/w it gets stomped */
  154.       tmp = *p_ptr;
  155.       (*p_ptr) += n + 1;
  156.       return get_symbol_by_copying(stacktop,(char *) tmp);
  157.       break;
  158.       
  159.     case READ_NULL:
  160.       ++(*p_ptr) ; 
  161.       return nil;
  162.       break;
  163.  
  164.     case READ_CONS:
  165.       ++ (*p_ptr);
  166.       return(read_cons_object(stacktop,p_ptr,reader));
  167.       break;
  168.  
  169.     case READ_VECTOR:
  170.       ++ (*p_ptr);
  171.       return(read_vector_object(stacktop,p_ptr, reader));
  172.       break;
  173.  
  174.     default:
  175.       CallError(stacktop,"Attempted to read impossible datatype",nil,NONCONTINUABLE);
  176.       break;
  177.     }    
  178.     }
  179.   else
  180.     { LispObject xx;
  181.       if (reader == nil)
  182.     CallError(stacktop,"No reader specified in socket-read",nil,NONCONTINUABLE);
  183.       tmp = *p_ptr; ++(*p_ptr);
  184.       STACK_TMP(reader);
  185.       xx=OBJECTIFY(p_ptr);
  186.       UNSTACK_TMP(reader);
  187.       return(EUCALL_3(apply2,GET_READER(CAR(reader),*tmp),xx,reader));
  188.     }
  189.  
  190.   CallError(stacktop,"Recieved a shock",nil,NONCONTINUABLE);
  191.   return nil; /* not ever */
  192. }
  193.  
  194. static LispObject read_cons_object(LispObject *stackbase,
  195.                    unsigned char **p_ptr,
  196.                    LispObject reader)
  197. {
  198.   LispObject *stacktop=stackbase+3;
  199.   int end=FALSE;
  200.   LispObject first_cons, this_cons;
  201.   
  202.   ARG_0(stackbase)=reader; ARG_1(stackbase)=nil;ARG_2(stackbase)=nil;
  203.   first_cons = EUCALL_2(Fn_cons,nil,nil);
  204.   ARG_1(stackbase)=first_cons;
  205.   this_cons = first_cons;
  206.   ARG_2(stackbase)=this_cons;
  207.   while (!end)
  208.     { LispObject xx;
  209.  
  210.       xx = read_obj(stacktop,p_ptr,ARG_0(stackbase));
  211.       this_cons=ARG_2(stackbase);
  212.       CAR(this_cons)=xx;
  213.       
  214.       switch(**p_ptr)
  215.     {
  216.       /* move along 1 */
  217.     case READ_CONS:
  218.       ++(*p_ptr);
  219.       xx = EUCALL_2(Fn_cons,nil,nil);
  220.       CDR(ARG_2(stackbase))=xx;
  221.       this_cons = xx;
  222.       ARG_2(stackbase)=this_cons;
  223.       break;
  224.       
  225.     case READ_NULL:
  226.       end = TRUE;
  227.       ++ (*p_ptr);
  228.       break;
  229.  
  230.     default:
  231.       end = TRUE;
  232.       xx = read_obj(stacktop,p_ptr,ARG_0(stackbase));
  233.       CDR(ARG_2(stackbase))=xx;
  234.       break;
  235.     }
  236.     }
  237.  
  238.   return ARG_1(stackbase);
  239. }
  240.  
  241. static LispObject read_vector_object(LispObject *stackbase,unsigned char **p_ptr, LispObject reader)
  242. {
  243.   LispObject read_obj(LispObject *,unsigned char **p_ptr, LispObject reader);
  244.   extern LispObject allocate_vector(LispObject *,int);
  245.  
  246.   LispObject *stacktop=stackbase+1;
  247.   LispObject vect;
  248.   int vlen;
  249.   int i;
  250.   
  251.   bcopy((char *)*p_ptr, (char *) &vlen, sizeof(int));
  252.   *p_ptr += sizeof(int);
  253.   
  254.   vect = allocate_vector(stacktop,vlen);
  255.   ARG_0(stackbase)=vect;
  256.  
  257.   for (i=0; i<vlen; i++)
  258.     {
  259.       STACK_TMP(reader);
  260.       vref(ARG_0(stackbase),i) = read_obj(stacktop,p_ptr,reader);
  261.       UNSTACK_TMP(reader);
  262.     }
  263.   
  264.   return(ARG_0(stackbase));
  265.  
  266. }
  267.  
  268. /* We assume that *stackbase is the object to be written here */
  269. void write_obj(LispObject *stackbase, LispObject ob,unsigned char **p_buf, LispObject reader)
  270. {
  271.   void write_cons_obj(LispObject *,LispObject ob,unsigned char **p_buf,LispObject reader);
  272.   
  273.   LispObject *stacktop=stackbase+1;
  274.   char *p_str;
  275.   int i;
  276.   
  277.   ARG_0(stackbase)=ob;
  278.   switch(typeof(ob))
  279.     {
  280.     case TYPE_INT:
  281.       **p_buf = READ_INT;
  282.       ++(*p_buf);
  283.       bcopy((char *) &(intval(ob)), *p_buf,sizeof(int));
  284.       *p_buf += sizeof(int);
  285.       break;
  286.  
  287.     case TYPE_FLOAT:
  288.        **p_buf = READ_FLOAT;
  289.       ++(*p_buf);
  290.        bcopy((char *) &(ob->FLOAT.fvalue), *p_buf, sizeof(double));
  291.        *p_buf += sizeof(double);
  292.       break;
  293.  
  294.     case TYPE_STRING:
  295.       **p_buf = READ_STRING;
  296.       ++ (*p_buf);
  297.       p_str = stringof(ob);
  298.       while(*p_str != '\0')
  299.     {
  300.       **p_buf = *p_str;
  301.       ++ (*p_buf);
  302.       ++ p_str;
  303.     }
  304.       **p_buf = *p_str;
  305.       ++ (*p_buf);
  306.       break;
  307.  
  308.     case TYPE_SYMBOL:  /* There are more cunning ways to do this... */
  309.       **p_buf = READ_SYMBOL;
  310.       ++ (*p_buf);
  311.       p_str = stringof(ob->SYMBOL.pname);
  312.       
  313.       while (*p_str != '\0')
  314.     {
  315.       **p_buf = *p_str;
  316.       ++ (*p_buf);
  317.       ++ p_str;
  318.     }
  319.       /* and copy the '\0' */
  320.       **p_buf = *p_str;
  321.       ++ (*p_buf);
  322.       break;
  323.  
  324.     case TYPE_NULL:
  325.       **p_buf = READ_NULL;
  326.       ++ (*p_buf);
  327.       break;
  328.       
  329.     case TYPE_CONS:
  330.       write_cons_obj(stacktop,ob,p_buf,reader);
  331.       break;
  332.  
  333.     case TYPE_VECTOR:
  334.       **p_buf = READ_VECTOR;
  335.       ++ (*p_buf);
  336.       bcopy((char *) &(ob->VECTOR.length), *p_buf,sizeof(int));
  337.       *p_buf += sizeof(int);
  338.       for (i=0; i< ob->VECTOR.length ; i++)
  339.     {
  340.       STACK_TMP(ob);
  341.       write_obj(stacktop,vref(ob,i),p_buf,reader);
  342.       UNSTACK_TMP(ob);
  343.     }
  344.       break;
  345.  
  346.     default:
  347.       /* reader is either nil or a 1-elt list contaning a reader */
  348.       if (reader == nil) 
  349.     CallError(stacktop,"No reader specified",ob,NONCONTINUABLE);
  350.       else
  351.     {
  352.       LispObject lst,tmp,tmp2;
  353.       char tmp3;
  354.       STACK_TMP(ob);
  355.       STACK_TMP(reader);
  356.       STACK_TMP(reader);
  357.       tmp=OBJECTIFY(p_buf);
  358.       UNSTACK_TMP(reader);
  359.       STACK_TMP(tmp);
  360.       EUCALLSET_2(lst,Fn_cons,reader,nil);
  361.       UNSTACK_TMP(tmp);
  362.       EUCALLSET_2(lst,Fn_cons,tmp,lst);
  363.       EUCALLSET_2(lst,Fn_cons,ARG_0(stackbase),lst);
  364.       UNSTACK_TMP(reader);
  365.       UNSTACK_TMP(ob);
  366.       STACK_TMP(ob);
  367.       STACK_TMP(reader);
  368.       tmp3=WRITER_ID(GET_WRITER(CAR(reader),(ob)));
  369.       UNSTACK_TMP(reader);
  370.       UNSTACK_TMP(ob);
  371.       **p_buf = tmp3;
  372.       ++ (*p_buf);
  373.       tmp=WRITER_FN(GET_WRITER(CAR(reader),(ob))); /* can gc */
  374.       UNSTACK_TMP(lst);
  375.       EUCALL_2(Fn_apply,tmp,lst);
  376.     }
  377.       break;
  378.     }
  379.   return ;
  380. }
  381.  
  382.  
  383. void write_cons_obj(LispObject *stackbase,LispObject ob,unsigned char **p_buf,LispObject reader)
  384. {
  385.   LispObject aob;
  386.   LispObject *stacktop=stackbase;
  387.   aob=ob;
  388.   while(is_cons(aob))
  389.     {
  390.       **p_buf = (unsigned char) READ_CONS;
  391.       ++ (*p_buf); 
  392.       STACK_TMP(reader);
  393.       STACK_TMP(CDR(aob));
  394.       write_obj(stacktop,CAR(aob),p_buf,reader);
  395.       UNSTACK_TMP(aob);
  396.       UNSTACK_TMP(reader);
  397.  
  398.     }
  399.   /* And the final CDR */
  400.   write_obj(stacktop,aob,p_buf,reader);
  401. }
  402.  
  403.  
  404. #define READER_ENTRIES (4)
  405.  
  406. MODULE Module_reader;
  407. LispObject Module_reader_values[READER_ENTRIES];
  408.  
  409.  
  410. void INIT_reader(LispObject *stacktop)
  411. {
  412.   open_module(stacktop,&Module_reader,Module_reader_values,"lreader",READER_ENTRIES);
  413.  
  414.   (void) make_module_function(stacktop,"make-obj-reader",Fn_make_obj_reader,1);
  415.   (void) make_module_function(stacktop,"add-reader",Fn_add_reader,3);
  416.   (void) make_module_function(stacktop,"read-next",Fn_read_next,2);
  417.   (void) make_module_function(stacktop,"write-next",Fn_write_next,3);
  418.   close_module();
  419. }
  420.