home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / bitvecs.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-10-06  |  6.8 KB  |  261 lines
  1. /* $Id: bitvecs.c,v 1.4 1992/01/09 22:28:42 pab Exp $
  2.  * 
  3.  * $Log: bitvecs.c,v $
  4.  * Revision 1.4  1992/01/09  22:28:42  pab
  5.  * Fixed for low tag ints
  6.  *
  7.  * Revision 1.3  1991/12/22  15:13:49  pab
  8.  * Xmas revision
  9.  *
  10.  * Revision 1.2  1991/09/11  12:07:00  pab
  11.  * 11/9/91 First Alpha release of modified system
  12.  *
  13.  * Revision 1.1  1991/08/12  16:49:26  pab
  14.  * Initial revision
  15.  *
  16.  * Revision 1.4  1991/02/11  21:24:13  pab
  17.  * tidied up...
  18.  *
  19.  * Revision 1.3  1991/02/04  17:33:39  kjp
  20.  * classof() standardisation.
  21.  *
  22.  * Revision 1.2  1990/11/29  22:45:19  pab
  23.  * Got vector arithmetic right. added integer->bit-vector
  24.  * NB: vectors indexed from 0. always have been. Always will be.
  25.  *
  26.  */
  27. /* ******************************************************************** */
  28. /* bit-vectors.c     Copyright (C) Codemist and University of Bath 1990 */
  29. /*                                                                      */
  30. /* Just so                                                    */
  31. /* ******************************************************************** */
  32.  
  33. /*
  34.  * Change Log:
  35.  *   Version 1, September 1990
  36.  *    28/11/90 added bit-vector->integer
  37.  */
  38.  
  39. #include <stdio.h>
  40. #include "funcalls.h"
  41. #include "defs.h"
  42. #include "structs.h"
  43. #include "global.h"
  44. #include "error.h"
  45. #include "allocate.h"
  46. #include "class.h"
  47. #include "modboot.h"
  48. #include "bootstrap.h"
  49.  
  50. static LispObject Bit_Vector;
  51.  
  52. EUFUN_1( Fn_make_bit_vector, lisplen)
  53. {
  54.   LispObject new;
  55.   int bytes,len;
  56.  
  57.   if (!is_fixnum(lisplen))
  58.     CallError(stacktop,"make-bit-vector: bad size",lisplen,NONCONTINUABLE);
  59.  
  60.   len = intval(lisplen);
  61.   
  62.   if (len <= 0)
  63.     CallError(stacktop,"make-bit-vector: bad size",lisplen,NONCONTINUABLE);
  64.  
  65.   bytes = len/8 + 1;
  66.  
  67.   new = allocate_c_object(stacktop,0,((int)sizeof(int))+ bytes); 
  68.   /* No lisp slots */
  69.  
  70.   lval_classof(new) = Bit_Vector;
  71.  
  72.   *((int *) &(new->C_OBJECT.first_c_byte)) = len;
  73.   for (len = 0 ; len < bytes ; len++)
  74.     ((char *) &(new->C_OBJECT.first_c_byte))[sizeof(int)+len] = 0;
  75.  
  76.   return(new);
  77. }
  78. EUFUN_CLOSE
  79.  
  80. EUFUN_1( Fn_bit_vector_p, obj)
  81. {
  82.   extern LispObject Fn_subclassp(LispObject*);
  83.  
  84.   if (EUCALL_2(Fn_subclassp,classof(obj),Bit_Vector) == nil) return(nil);
  85.   return(lisptrue);
  86. }
  87. EUFUN_CLOSE
  88.  
  89. EUFUN_1( Fn_bit_vector_length, v)
  90. {
  91.   if (EUCALL_1(Fn_bit_vector_p,v) == nil)
  92.     CallError(stacktop,"bit-vector-length: bad bit vector",v,NONCONTINUABLE);
  93.  
  94.   /* v = ARG_0(stackbase);  /* Not needed as Fn_vector_p cannot GC?? */
  95.   return(allocate_integer(stacktop, *(int *) &((v->C_OBJECT.first_c_byte))));
  96. }
  97. EUFUN_CLOSE
  98.   
  99. EUFUN_2( Fn_bit_vector_ref,  v, i)
  100. {
  101.   int index,byte,bit;
  102.   int size;
  103.  
  104.   if (EUCALL_1(Fn_bit_vector_p,v) == nil)
  105.     CallError(stacktop,"bit-vector-ref: non bit-vector",v,NONCONTINUABLE);
  106.  
  107.   /* v = ARG_0(stackbase);  /* Not needed as Fn_vector_p cannot GC?? */
  108.   size = *((int *) &(v->C_OBJECT.first_c_byte));
  109.  
  110.   if (!is_fixnum(i))
  111.     CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
  112.  
  113.   index = intval(i);
  114.   if (index < 0 || index >= size)
  115.     CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
  116.  
  117.   byte = index/8;
  118.   bit = index%8;
  119.  
  120.   if ((1 << bit) &
  121.         *(((char *) &(v->C_OBJECT.first_c_byte)) + sizeof(int) + byte))
  122.     return(allocate_integer(stacktop,1));
  123.  
  124.   return(allocate_integer(stacktop,0));
  125. }
  126. EUFUN_CLOSE
  127.  
  128. EUFUN_3( Fn_bit_vector_ref_setter, v, i, val)
  129. {
  130.   int index,byte,bit;
  131.   int size,state;
  132.  
  133.   if (EUCALL_1(Fn_bit_vector_p,v) == nil)
  134.     CallError(stacktop,"bit-vector-ref: non bit-vector",v,NONCONTINUABLE);
  135.  
  136.   size = *((int *) &(v->C_OBJECT.first_c_byte));
  137.  
  138.   if (!is_fixnum(i))
  139.     CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
  140.  
  141.   index = intval(i);
  142.   if (index < 0 || index >= size)
  143.     CallError(stacktop,"bit-vector-ref: bad index",i,NONCONTINUABLE);
  144.  
  145.   if (!is_fixnum(val))
  146.     CallError(stacktop,
  147.           "(setter bit-vector-ref): bad bit value",val,NONCONTINUABLE);
  148.  
  149.   if ((state = intval(val)) != 0 && state != 1)
  150.     CallError(stacktop,
  151.           "(setter bit-vector-ref): bad bit value",val,NONCONTINUABLE);
  152.  
  153.   byte = index/8;
  154.   bit = index%8;
  155.  
  156.   if (state == 1)
  157.     *(((char *) &(v->C_OBJECT.first_c_byte)) + sizeof(int) + byte)
  158.       |= (char) (1 << bit);
  159.   else
  160.     *(((char *) &(v->C_OBJECT.first_c_byte)) + sizeof(int) + byte)
  161.       &= (char) ~(1 << bit);    
  162.  
  163.   return(v);
  164. }
  165. EUFUN_CLOSE
  166.  
  167. /* conver intgers to bit-vectors */
  168. EUFUN_1( Fn_integer_to_bit_vector, x)
  169. {
  170.   LispObject vect;
  171.   int i;
  172.   unsigned char v_buf[sizeof(int)];
  173.   unsigned char *v_ptr;
  174.  
  175.   EUCALLSET_1(vect, Fn_make_bit_vector,
  176.                 allocate_integer(stacktop,sizeof(int) * 8));
  177.   
  178.   x = ARG_0(stackbase);
  179.   bcopy((unsigned char *) &(intval(x)), v_buf,sizeof(int));
  180.   v_ptr =  ((unsigned char *) &(vect->C_OBJECT.first_c_byte)) + sizeof(int);
  181.   
  182.   /* Hmm, let's assume that this is big-endian */
  183. #if 1  
  184.   for (i=0; i < sizeof(int) ; i++)
  185.     {
  186.       v_ptr[i] = v_buf[(sizeof(int) - i) - 1];
  187.     }
  188. #else
  189.   for (i=0; i < sizeof(int) ; i++)
  190.     v_ptr[sizeof(int)-i-1] = v_buf[(sizeof(int) - 1) - 1];
  191. #endif
  192.   
  193.   return vect;
  194. }
  195. EUFUN_CLOSE
  196.  
  197. /* Print method... */
  198.  
  199. EUFUN_2( Md_generic_prin,  v, str)
  200. {
  201.   int i,max;
  202.  
  203.   if (!is_stream(str))
  204.     CallError(stacktop,"generic-prin: bad stream",str,NONCONTINUABLE);
  205.  
  206.   fprintf(str->STREAM.handle,"#<bit-vector: ");
  207.   max = *((int *)&(v->C_OBJECT.first_c_byte));
  208.   for (i=0; i<max; ++i) {
  209.     int byte,bit;
  210.  
  211.     byte = i/8;
  212.     bit = i%8;
  213.  
  214.     fputc(((1 << bit) 
  215.        & *(((char *) &(v->C_OBJECT.first_c_byte)) 
  216.            + sizeof(int) + byte) ? '1' : '0'),str->STREAM.handle);
  217.   }
  218.   fprintf(str->STREAM.handle,">");
  219.  
  220.   return(v);
  221. }
  222. EUFUN_CLOSE
  223.   
  224. #define BIT_VECTORS_ENTRIES (8)
  225. MODULE Module_bit_vectors;
  226. LispObject Module_bit_vectors_values[BIT_VECTORS_ENTRIES];
  227.  
  228. void initialise_bit_vectors(LispObject *stacktop)
  229. {
  230.   extern LispObject Primitive_Class;
  231.   extern LispObject generic_generic_prin;
  232.   extern void set_anon_associate(LispObject *,LispObject,LispObject);
  233.   LispObject get,set;
  234.  
  235.   open_module(stacktop,&Module_bit_vectors,Module_bit_vectors_values,
  236.           "bit-vectors",BIT_VECTORS_ENTRIES);
  237.  
  238.   gen_class(stacktop,&Bit_Vector,"bit-vector",Primitive_Class,Object);
  239.   add_root(&Bit_Vector);
  240.   (void) make_module_entry(stacktop,"bit-vector",Bit_Vector);
  241.   (void) make_module_function(stacktop,"make-bit-vector",Fn_make_bit_vector,1);
  242.   (void) make_module_function(stacktop,"bit-vector-p",Fn_bit_vector_p,1);
  243.   (void) make_module_function(stacktop,
  244.                   "bit-vector-length",Fn_bit_vector_length,1);
  245.   (void) make_module_function(stacktop,
  246.                "integer->bit-vector",Fn_integer_to_bit_vector,1);
  247.   get = make_module_function(stacktop,"bit-vector-ref",Fn_bit_vector_ref,2);
  248.   STACK_TMP(get);
  249.   set = make_unexported_module_function(stacktop,"bit-vector-ref-setter",
  250.                     Fn_bit_vector_ref_setter,3);
  251.   UNSTACK_TMP(get);
  252.   set_anon_associate(stacktop,get,set);
  253.  
  254.   (void) make_module_function(stacktop,"generic_generic_prin,BitVector",
  255.                   Md_generic_prin,2);
  256.  
  257.   close_module();
  258. }
  259.  
  260.              
  261.