home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / bitstr.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  26KB  |  873 lines
  1. /* -*-C-*-
  2.  
  3. $Id: bitstr.c,v 9.63 2000/12/05 21:23:43 cph Exp $
  4.  
  5. Copyright (c) 1987-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Bit string primitives.
  23.    Conversions between nonnegative integers and bit strings are
  24.    implemented here; they use the standard binary encoding, in which
  25.    each index selects the bit corresponding to that power of 2.  Thus
  26.    bit 0 is the LSB. */
  27.  
  28. #include "scheme.h"
  29. #include "prims.h"
  30. #include "bitstr.h"
  31.  
  32. static void EXFUN
  33.   (copy_bits, (SCHEME_OBJECT *, long, SCHEME_OBJECT *, long, long));
  34.  
  35. static SCHEME_OBJECT
  36. DEFUN (allocate_bit_string, (length), long length)
  37. {
  38.   long total_pointers;
  39.   SCHEME_OBJECT result;
  40.  
  41.   total_pointers = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (length)));
  42.   result = (allocate_non_marked_vector (TC_BIT_STRING, total_pointers, true));
  43.   FAST_MEMORY_SET (result, BIT_STRING_LENGTH_OFFSET, length);
  44.   return (result);
  45. }
  46.  
  47. /* (BIT-STRING-ALLOCATE length)
  48.    Returns an uninitialized bit string of the given length. */
  49.  
  50. DEFINE_PRIMITIVE ("BIT-STRING-ALLOCATE", Prim_bit_string_allocate, 1, 1, 0)
  51. {
  52.   PRIMITIVE_HEADER (1);
  53.   PRIMITIVE_RETURN (allocate_bit_string (arg_nonnegative_integer (1)));
  54. }
  55.  
  56. /* (BIT-STRING? object)
  57.    Returns #T iff object is a bit string. */
  58.  
  59. DEFINE_PRIMITIVE ("BIT-STRING?", Prim_bit_string_p, 1, 1, 0)
  60. {
  61.   fast SCHEME_OBJECT object;
  62.   PRIMITIVE_HEADER (1);
  63.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), object);
  64.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (BIT_STRING_P (object)));
  65. }
  66.  
  67. void
  68. DEFUN (fill_bit_string, (bit_string, sense),
  69.        SCHEME_OBJECT bit_string AND
  70.        int sense)
  71. {
  72.   SCHEME_OBJECT *scanner;
  73.   SCHEME_OBJECT filler;
  74.   long i;
  75.  
  76.   filler = ((SCHEME_OBJECT) (sense ? (~ 0) : 0));
  77.   scanner = BIT_STRING_HIGH_PTR (bit_string);
  78.   for (i = BIT_STRING_LENGTH_TO_GC_LENGTH (BIT_STRING_LENGTH (bit_string));
  79.        (i > 0); i -= 1)
  80.     (* (DEC_BIT_STRING_PTR (scanner))) = filler;
  81. }
  82.  
  83. extern void EXFUN (clear_bit_string, (SCHEME_OBJECT));
  84.  
  85. void
  86. DEFUN (clear_bit_string, (bit_string), SCHEME_OBJECT bit_string)
  87. {
  88.   SCHEME_OBJECT *scanner;
  89.   long i;
  90.  
  91.   scanner = BIT_STRING_HIGH_PTR (bit_string);
  92.   for (i = BIT_STRING_LENGTH_TO_GC_LENGTH (BIT_STRING_LENGTH (bit_string));
  93.        (i > 0); i -= 1)
  94.     (* (DEC_BIT_STRING_PTR (scanner))) = 0;
  95. }
  96.  
  97. DEFINE_PRIMITIVE ("MAKE-BIT-STRING", Prim_make_bit_string, 2, 2,
  98.  "(SIZE INITIALIZATION)\n\
  99. Returns a bit string of the specified size with all the bits\n\
  100. set to zero if the initialization is false, one otherwise.")
  101. {
  102.   SCHEME_OBJECT result;
  103.   PRIMITIVE_HEADER (2);
  104.   result = allocate_bit_string (arg_nonnegative_integer (1));
  105.   fill_bit_string (result, (OBJECT_TO_BOOLEAN (ARG_REF (2))));
  106.   PRIMITIVE_RETURN (result);
  107. }
  108.  
  109. DEFINE_PRIMITIVE ("BIT-STRING-FILL!", Prim_bit_string_fill_x, 2, 2,
  110.   "(BIT-STRING INITIALIZATION)\n\
  111. Fills the bit string with zeros if the initialization is false, \
  112. otherwise fills it with ones.")
  113. {
  114.   PRIMITIVE_HEADER (2);
  115.   CHECK_ARG (1, BIT_STRING_P);
  116.   fill_bit_string ((ARG_REF (1)), (OBJECT_TO_BOOLEAN (ARG_REF (2))));
  117.   PRIMITIVE_RETURN (UNSPECIFIC);
  118. }
  119.  
  120. /*  */
  121.  
  122. DEFINE_PRIMITIVE ("BIT-STRING-LENGTH", Prim_bit_string_length, 1, 1,
  123.   "(BIT-STRING)\n\
  124. Returns the number of bits in BIT-STRING.")
  125. {
  126.   PRIMITIVE_HEADER (1);
  127.   CHECK_ARG (1, BIT_STRING_P);
  128.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (BIT_STRING_LENGTH (ARG_REF (1))));
  129. }
  130.  
  131. #define REF_INITIALIZATION()                        \
  132.   fast SCHEME_OBJECT bit_string;                    \
  133.   fast long index;                            \
  134.   fast SCHEME_OBJECT *ptr;                        \
  135.   fast long mask;                            \
  136.   PRIMITIVE_HEADER (2);                            \
  137.                                     \
  138.   CHECK_ARG (1, BIT_STRING_P);                        \
  139.   bit_string = (ARG_REF (1));                        \
  140.   index = (arg_nonnegative_integer (2));                \
  141.   if (index >= (BIT_STRING_LENGTH (bit_string)))            \
  142.     error_bad_range_arg (2);                        \
  143.                                     \
  144.   ptr =                                    \
  145.     (MEMORY_LOC                                \
  146.      (bit_string, (BIT_STRING_INDEX_TO_WORD (bit_string, index))));    \
  147.   mask = (1L << (index % OBJECT_LENGTH))
  148.  
  149. DEFINE_PRIMITIVE ("BIT-STRING-REF", Prim_bit_string_ref, 2, 2,
  150.   "(BIT-STRING INDEX)\n\
  151. Returns the boolean value of the indexed bit.")
  152. {
  153.   REF_INITIALIZATION ();
  154.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (((BIT_STRING_WORD (ptr)) & mask) != 0));
  155. }
  156.  
  157. /*  */
  158.  
  159. DEFINE_PRIMITIVE ("BIT-STRING-CLEAR!", Prim_bit_string_clear_x, 2, 2,
  160.   "(BIT-STRING INDEX)\n\
  161. Sets the indexed bit to zero, returning its previous value as a boolean.")
  162. {
  163.   REF_INITIALIZATION ();
  164.   if (((BIT_STRING_WORD (ptr)) & mask) == 0)
  165.     PRIMITIVE_RETURN (SHARP_F);
  166.   (BIT_STRING_WORD (ptr)) &= ~mask;
  167.   PRIMITIVE_RETURN (SHARP_T);
  168. }
  169.  
  170. DEFINE_PRIMITIVE ("BIT-STRING-SET!", Prim_bit_string_set_x, 2, 2, 
  171.   "(BIT-STRING INDEX)\n\
  172. Sets the indexed bit to one, returning its previous value as a boolean.")
  173. {
  174.   REF_INITIALIZATION ();
  175.   if (((BIT_STRING_WORD (ptr)) & mask) != 0)
  176.     PRIMITIVE_RETURN (SHARP_T);
  177.   (BIT_STRING_WORD (ptr)) |= mask;
  178.   PRIMITIVE_RETURN (SHARP_F);
  179. }
  180.  
  181. #define ZERO_SECTION_P()                        \
  182. {                                    \
  183.   for (i = (length / OBJECT_LENGTH); (i > 0); i -= 1)            \
  184.     if ((* (DEC_BIT_STRING_PTR (scan))) != 0)                \
  185.       PRIMITIVE_RETURN (SHARP_F);                    \
  186.   PRIMITIVE_RETURN (SHARP_T);                        \
  187. }
  188.  
  189. DEFINE_PRIMITIVE ("BIT-STRING-ZERO?", Prim_bit_string_zero_p, 1, 1,
  190.  "(BIT-STRING)\n\
  191. Returns true the argument has no \"set\" bits.")
  192. {
  193.   fast SCHEME_OBJECT bit_string;
  194.   fast SCHEME_OBJECT *scan;
  195.   fast long i;
  196.   long length, odd_bits;
  197.   PRIMITIVE_HEADER (1);
  198.   CHECK_ARG (1, BIT_STRING_P);
  199.   bit_string = (ARG_REF (1));
  200.   length = (BIT_STRING_LENGTH (bit_string));
  201.   odd_bits = (length % OBJECT_LENGTH);
  202.   scan = (BIT_STRING_HIGH_PTR (bit_string));
  203.   if (odd_bits == 0)
  204.     {
  205.       ZERO_SECTION_P ();
  206.     }
  207.   else if (((BIT_STRING_WORD (scan)) & (LOW_MASK (odd_bits))) != 0)
  208.     PRIMITIVE_RETURN (SHARP_F);
  209.   else
  210.     {
  211.       DEC_BIT_STRING_PTR (scan);
  212.       ZERO_SECTION_P ();
  213.     }
  214. }
  215.  
  216. #define EQUAL_SECTIONS_P()                        \
  217. {                                    \
  218.   for (i = (length / OBJECT_LENGTH); (i > 0); i -= 1)            \
  219.     if ((* (DEC_BIT_STRING_PTR (scan1))) !=                \
  220.     (* (DEC_BIT_STRING_PTR (scan2))))                \
  221.       PRIMITIVE_RETURN (SHARP_F);                    \
  222.   PRIMITIVE_RETURN (SHARP_T);                        \
  223. }
  224.  
  225. DEFINE_PRIMITIVE ("BIT-STRING=?", Prim_bit_string_equal_p, 2, 2, 
  226.   "(BIT-STRING-1 BIT-STRING-2)\n\
  227. Returns true iff the two bit strings contain the same bits.")
  228. {
  229.   SCHEME_OBJECT bit_string_1, bit_string_2;
  230.   long length;
  231.   fast SCHEME_OBJECT *scan1, *scan2;
  232.   fast long i;
  233.   long odd_bits;
  234.   PRIMITIVE_HEADER (2);
  235.   CHECK_ARG (1, BIT_STRING_P);
  236.   CHECK_ARG (2, BIT_STRING_P);
  237.   bit_string_1 = (ARG_REF (1));
  238.   bit_string_2 = (ARG_REF (2));
  239.   length = BIT_STRING_LENGTH (bit_string_1);
  240.   if (length != BIT_STRING_LENGTH (bit_string_2))
  241.     PRIMITIVE_RETURN (SHARP_F);
  242.   scan1 = (BIT_STRING_HIGH_PTR (bit_string_1));
  243.   scan2 = (BIT_STRING_HIGH_PTR (bit_string_2));
  244.   odd_bits = (length % OBJECT_LENGTH);
  245.   if (odd_bits == 0)
  246.     {
  247.       EQUAL_SECTIONS_P ();
  248.     }
  249.   else
  250.     {
  251.       long mask;
  252.  
  253.       mask = (LOW_MASK (odd_bits));
  254.       if (((BIT_STRING_MSW (bit_string_1)) & mask) !=
  255.       ((BIT_STRING_MSW (bit_string_2)) & mask))
  256.     PRIMITIVE_RETURN (SHARP_F);
  257.       else
  258.     {
  259.       DEC_BIT_STRING_PTR (scan1);
  260.       DEC_BIT_STRING_PTR (scan2);
  261.       EQUAL_SECTIONS_P ();
  262.     }
  263.     }
  264. }
  265.  
  266. /* (BIT-STRING-OPERATION! destination source)
  267.    Modifies destination to be the result of using OPERATION bitwise on
  268.    destination and source. */
  269.  
  270. #define BITWISE_OP(action)                        \
  271. {                                    \
  272.   SCHEME_OBJECT bit_string_1, bit_string_2;                \
  273.   fast long i;                                \
  274.   fast SCHEME_OBJECT *scan1, *scan2;                    \
  275.   PRIMITIVE_HEADER (2);                            \
  276.   bit_string_1 = (ARG_REF (1));                        \
  277.   bit_string_2 = (ARG_REF (2));                        \
  278.   if ((BIT_STRING_LENGTH (bit_string_1)) !=                \
  279.       (BIT_STRING_LENGTH (bit_string_2)))                \
  280.     error_bad_range_arg (1);                        \
  281.   scan1 = (BIT_STRING_HIGH_PTR (bit_string_1));                \
  282.   scan2 = (BIT_STRING_HIGH_PTR (bit_string_2));                \
  283.   for (i = ((VECTOR_LENGTH (bit_string_1)) - 1); (i > 0); i -= 1)    \
  284.     (* (DEC_BIT_STRING_PTR (scan1))) action                \
  285.       (* (DEC_BIT_STRING_PTR (scan2)));                    \
  286.   PRIMITIVE_RETURN (UNSPECIFIC);                    \
  287. }
  288.  
  289. DEFINE_PRIMITIVE ("BIT-STRING-MOVE!", Prim_bit_string_move_x, 2, 2, 0)
  290.      BITWISE_OP (=)
  291.  
  292. DEFINE_PRIMITIVE ("BIT-STRING-MOVEC!", Prim_bit_string_movec_x, 2, 2, 0)
  293.      BITWISE_OP (=~)
  294.  
  295. DEFINE_PRIMITIVE ("BIT-STRING-OR!", Prim_bit_string_or_x, 2, 2, 0)
  296.      BITWISE_OP (|=)
  297.  
  298. DEFINE_PRIMITIVE ("BIT-STRING-AND!", Prim_bit_string_and_x, 2, 2, 0)
  299.      BITWISE_OP (&=)
  300.  
  301. DEFINE_PRIMITIVE ("BIT-STRING-ANDC!", Prim_bit_string_andc_x, 2, 2, 0)
  302.      BITWISE_OP (&=~)
  303.  
  304. DEFINE_PRIMITIVE ("BIT-STRING-XOR!", Prim_bit_string_xor_x, 2, 2, 0)
  305.      BITWISE_OP (^=)
  306.  
  307. DEFINE_PRIMITIVE ("BIT-SUBSTRING-MOVE-RIGHT!", Prim_bit_substring_move_right_x, 5, 5, 
  308.  "(SOURCE START1 END1 DESTINATION START2)\n\
  309. Destructively copies the substring of SOURCE between START1 and \
  310. END1 into DESTINATION at START2.  The copying is done from the \
  311. MSB to the LSB (which only matters when SOURCE and DESTINATION \
  312. are the same).")
  313. {
  314.   fast SCHEME_OBJECT bit_string_1, bit_string_2;
  315.   long start1, end1, start2, end2, nbits;
  316.   long end1_mod, end2_mod;
  317.   PRIMITIVE_HEADER (5);
  318.   CHECK_ARG (1, BIT_STRING_P);
  319.   bit_string_1 = (ARG_REF (1));
  320.   start1 = (arg_nonnegative_integer (2));
  321.   end1 = (arg_nonnegative_integer (3));
  322.   CHECK_ARG (4, BIT_STRING_P);
  323.   bit_string_2 = (ARG_REF (4));
  324.   start2 = (arg_nonnegative_integer (5));
  325.   nbits = (end1 - start1);
  326.   end2 = (start2 + nbits);
  327.   if ((start1 < 0) || (start1 > end1))
  328.     error_bad_range_arg (2);
  329.   if (end1 > (BIT_STRING_LENGTH (bit_string_1)))
  330.     error_bad_range_arg (3);
  331.   if ((start2 < 0) || (end2 > (BIT_STRING_LENGTH (bit_string_2))))
  332.     error_bad_range_arg (5);
  333.   end1_mod = (end1 % OBJECT_LENGTH);
  334.   end2_mod = (end2 % OBJECT_LENGTH);
  335.   /* Using `BIT_STRING_INDEX_TO_WORD' here with -1 offset will work in every
  336.      case except when the `end' is 0.  In this case the result of
  337.      the expression `(-1 / OBJECT_LENGTH)' is either 0 or -1, at
  338.      the discretion of the C compiler being used.  This doesn't
  339.      matter because if `end' is zero, then no bits will be moved. */
  340.   copy_bits ((MEMORY_LOC
  341.           (bit_string_1,
  342.            (BIT_STRING_INDEX_TO_WORD (bit_string_1, (end1 - 1))))),
  343.         ((end1_mod == 0) ? 0 : (OBJECT_LENGTH - end1_mod)),
  344.         (MEMORY_LOC
  345.          (bit_string_2,
  346.           (BIT_STRING_INDEX_TO_WORD (bit_string_2, (end2 - 1))))),
  347.         ((end2_mod == 0) ? 0 : (OBJECT_LENGTH - end2_mod)),
  348.         nbits);
  349.   PRIMITIVE_RETURN (UNSPECIFIC);
  350. }
  351.  
  352. #define MASKED_TRANSFER(source, destination, nbits, offset) do        \
  353. {                                    \
  354.   long mask = (ANY_MASK (nbits, offset));                \
  355.   (BIT_STRING_WORD (destination))                    \
  356.     = (((BIT_STRING_WORD (source)) & mask)                \
  357.        | ((BIT_STRING_WORD (destination)) &~ mask));            \
  358. } while (0)
  359.  
  360. /* This procedure copies bits from one place to another.
  361.    The offsets are measured from the MSB of the first SCHEME_OBJECT of
  362.    each of the arguments SOURCE and DESTINATION.  It copies the bits
  363.    starting with the MSB of a bit string and moving down. */
  364.  
  365. static void
  366. DEFUN (copy_bits,
  367.        (source, source_offset, destination, destination_offset, nbits),
  368.        SCHEME_OBJECT * source AND
  369.        long source_offset AND
  370.        SCHEME_OBJECT * destination AND
  371.        long destination_offset AND
  372.        long nbits)
  373. {
  374.  
  375.   if (nbits == 0)
  376.     return;
  377.  
  378.   /* This common case can be done very quickly, by splitting the
  379.      bit string into three parts.  Since the source and destination are
  380.      aligned relative to one another, the main body of bits can be
  381.      transferred as SCHEME_OBJECTs, and only the `head' and `tail' need be
  382.      treated specially.  */
  383.   if (source_offset == destination_offset)
  384.     {
  385.       if (source_offset != 0)
  386.     {
  387.       long head = (OBJECT_LENGTH - source_offset);
  388.       if (nbits <= head)
  389.         {
  390.           MASKED_TRANSFER (source, destination, nbits, (head - nbits));
  391.           nbits = 0;
  392.         }
  393.       else
  394.         {
  395.           long mask = (LOW_MASK (head));
  396.           SCHEME_OBJECT temp = (BIT_STRING_WORD (destination));
  397.           (* (DEC_BIT_STRING_PTR (destination)))
  398.         = (((* (DEC_BIT_STRING_PTR (source))) & mask)
  399.            | (temp &~ mask));
  400.           nbits -= head;
  401.         }
  402.     }
  403.       while (nbits >= OBJECT_LENGTH)
  404.     {
  405.       (* (DEC_BIT_STRING_PTR (destination)))
  406.         = (* (DEC_BIT_STRING_PTR (source)));
  407.       nbits -= OBJECT_LENGTH;
  408.     }
  409.       if (nbits > 0)
  410.     MASKED_TRANSFER (source, destination, nbits, (OBJECT_LENGTH - nbits));
  411.     }
  412.  
  413.   else if (source_offset < destination_offset)
  414.     {
  415.       long offset1 = (destination_offset - source_offset);
  416.       long offset2 = (OBJECT_LENGTH - offset1);
  417.       long head = (OBJECT_LENGTH - destination_offset);
  418.       if (nbits <= head)
  419.     {
  420.       long mask = (ANY_MASK (nbits, (head - nbits)));
  421.       (BIT_STRING_WORD (destination))
  422.         = ((((BIT_STRING_WORD (source)) >> offset1) & mask)
  423.            | ((BIT_STRING_WORD (destination)) &~ mask));
  424.     }
  425.       else
  426.     {
  427.       long mask1 = (LOW_MASK (offset1));
  428.       long mask2 = (LOW_MASK (offset2));
  429.       {
  430.         long mask = (LOW_MASK (head));
  431.         SCHEME_OBJECT temp = (BIT_STRING_WORD (destination));
  432.         (* (DEC_BIT_STRING_PTR (destination)))
  433.           = ((((BIT_STRING_WORD (source)) >> offset1) & mask)
  434.          | (temp &~ mask));
  435.       }
  436.       nbits -= head;
  437.       while (nbits >= OBJECT_LENGTH)
  438.         {
  439.           long i
  440.         = (((* (DEC_BIT_STRING_PTR (source))) & mask1) << offset2);
  441.           (* (DEC_BIT_STRING_PTR (destination)))
  442.         = ((((BIT_STRING_WORD (source)) >> offset1) & mask2) | i);
  443.           nbits -= OBJECT_LENGTH;
  444.         }
  445.       if (nbits > 0)
  446.         {
  447.           long dest_tail
  448.         = ((BIT_STRING_WORD (destination))
  449.            & (LOW_MASK (OBJECT_LENGTH - nbits)));
  450.           if (nbits <= offset1)
  451.         (BIT_STRING_WORD (destination))
  452.           = ((((BIT_STRING_WORD (source))
  453.                & (ANY_MASK (nbits, (offset1 - nbits))))
  454.               << offset2)
  455.              | dest_tail);
  456.           else
  457.         {
  458.           long i
  459.             = (((* (DEC_BIT_STRING_PTR (source))) & mask1) << offset2);
  460.           long j = (nbits - offset1);
  461.           (BIT_STRING_WORD (destination))
  462.             = ((((BIT_STRING_WORD (source))
  463.              &
  464.              (ANY_MASK (j, (OBJECT_LENGTH - j))))
  465.             >> offset1)
  466.                | i
  467.                | dest_tail);
  468.         }
  469.         }
  470.     }
  471.     }
  472.  
  473.   else                /* if (source_offset > destination_offset) */
  474.     {
  475.       long offset1 = (source_offset - destination_offset);
  476.       long offset2 = (OBJECT_LENGTH - offset1);
  477.       long head = (OBJECT_LENGTH - source_offset);
  478.       if (nbits <= head)
  479.     {
  480.       long mask = (ANY_MASK (nbits, (offset1 + (head - nbits))));
  481.       (BIT_STRING_WORD (destination))
  482.         = ((((BIT_STRING_WORD (source)) << offset1) & mask)
  483.            | ((BIT_STRING_WORD (destination)) &~ mask));
  484.     }
  485.       else
  486.     {
  487.       long mask1 = (LOW_MASK (offset1));
  488.       long dest_buffer
  489.         = (((head + offset1) < OBJECT_LENGTH)
  490.            ? ((BIT_STRING_WORD (destination))
  491.           &~ (LOW_MASK (head + offset1)))
  492.            : 0);
  493.       dest_buffer
  494.         |= (((* (DEC_BIT_STRING_PTR (source))) & (LOW_MASK (head)))
  495.         << offset1);
  496.       nbits -= head;
  497.       while (nbits >= OBJECT_LENGTH)
  498.         {
  499.           (* (DEC_BIT_STRING_PTR (destination)))
  500.         = (dest_buffer
  501.            | (((BIT_STRING_WORD (source)) >> offset2) & mask1));
  502.           dest_buffer = ((* (DEC_BIT_STRING_PTR (source))) << offset1);
  503.           nbits -= OBJECT_LENGTH;
  504.         }
  505.       if (nbits <= offset1)
  506.         (BIT_STRING_WORD (destination))
  507.           = (dest_buffer
  508.          | ((BIT_STRING_WORD (destination))
  509.             & (LOW_MASK (offset1 - nbits)))
  510.          | (((BIT_STRING_WORD (source)) >> offset2)
  511.             & (ANY_MASK (nbits, (offset1 - nbits)))));
  512.       else
  513.         {
  514.           (* (DEC_BIT_STRING_PTR (destination)))
  515.         = (dest_buffer
  516.            | (((BIT_STRING_WORD (source)) >> offset2) & mask1));
  517.           nbits -= offset1;
  518.           {
  519.         long mask = (LOW_MASK (OBJECT_LENGTH - nbits));
  520.         (BIT_STRING_WORD (destination))
  521.           = (((BIT_STRING_WORD (destination)) & mask)
  522.              | (((BIT_STRING_WORD (source)) << offset1) &~ mask));
  523.           }
  524.         }
  525.     }
  526.     }
  527. }
  528.  
  529. /* Integer <-> Bit-string Conversions */
  530.  
  531. long
  532. DEFUN (count_significant_bits, (number, start), long number AND long start)
  533. {
  534.   long significant_bits, i;
  535.  
  536.   significant_bits = start;
  537.   for (i = (1L << (start - 1)); (i >= 0); i >>= 1)
  538.     {
  539.       if (number >= i)
  540.     break;
  541.       significant_bits -= 1;
  542.     }
  543.   return (significant_bits);
  544. }
  545.  
  546. long
  547. DEFUN (long_significant_bits, (number), long number)
  548. {
  549.   return
  550.     ((number < 0)
  551.      ? ((sizeof (long)) * CHAR_BIT)
  552.      : (count_significant_bits (number, (((sizeof (long)) * CHAR_BIT) - 1))));
  553. }
  554.  
  555. SCHEME_OBJECT
  556. DEFUN (zero_to_bit_string, (length), long length)
  557. {
  558.   SCHEME_OBJECT result;
  559.  
  560.   result = (allocate_bit_string (length));
  561.   clear_bit_string (result);
  562.   return (result);
  563. }
  564.  
  565. SCHEME_OBJECT
  566. DEFUN (long_to_bit_string, (length, number), long length AND long number)
  567. {
  568.   if (number < 0)
  569.     error_bad_range_arg (2);
  570.  
  571.   if (number == 0)
  572.     {
  573.       return (zero_to_bit_string (length));
  574.     }
  575.   else
  576.     {
  577.       SCHEME_OBJECT result;
  578.  
  579.       if (length < (long_significant_bits (number)))
  580.     error_bad_range_arg (2);
  581.       result = (zero_to_bit_string (length));
  582.       (BIT_STRING_LSW (result)) = number;
  583.       return (result);
  584.     }
  585. }
  586.  
  587. static void
  588. DEFUN (btbs_consumer, (result_ptr, digit),
  589.        PTR result_ptr
  590.        AND long digit)
  591. {
  592.   (* (INC_BIT_STRING_PTR (* ((unsigned char **) result_ptr))))
  593.     = ((unsigned char) digit);
  594. }
  595.  
  596. SCHEME_OBJECT
  597. DEFUN (bignum_to_bit_string, (length, bignum),
  598.        long length AND SCHEME_OBJECT bignum)
  599. {
  600.   switch (bignum_test (bignum))
  601.     {
  602.     case bignum_comparison_equal:
  603.       return (zero_to_bit_string (length));
  604.     case bignum_comparison_less:
  605.       error_bad_range_arg (2);
  606.     case bignum_comparison_greater:
  607.       if (! (bignum_fits_in_word_p (bignum, length, 0)))
  608.     error_bad_range_arg (2);
  609.       {
  610.     SCHEME_OBJECT result = (zero_to_bit_string (length));
  611.     unsigned char * result_ptr =
  612.       ((unsigned char *) (BIT_STRING_LOW_PTR (result)));
  613.     bignum_to_digit_stream
  614.       (bignum, (1L << CHAR_BIT), btbs_consumer, (&result_ptr));
  615.     return (result);
  616.       }
  617.     default:
  618.       /*NOTREACHED*/
  619.       return (0);
  620.     }
  621. }
  622.  
  623. struct bitstr_to_bignm_context
  624. {
  625.   unsigned char *source_ptr;
  626.   unsigned int mask;
  627. };
  628.  
  629. static unsigned int
  630. DEFUN (bstb_producer, (context), PTR context)
  631. {
  632.   struct bitstr_to_bignm_context * c = context;
  633.   unsigned int result = (c->mask & (BIT_STRING_WORD (c->source_ptr)));
  634.   c->mask = (LOW_MASK (CHAR_BIT));
  635.   DEC_BIT_STRING_PTR (c->source_ptr);
  636.   return (result);
  637. }
  638.  
  639. SCHEME_OBJECT
  640. DEFUN (bit_string_to_bignum, (nbits, bitstr),
  641.        long nbits AND SCHEME_OBJECT bitstr)
  642. {
  643.   struct bitstr_to_bignm_context context;
  644.   int ndigits, skip;
  645.  
  646.   ndigits = ((nbits + (CHAR_BIT - 1)) / CHAR_BIT);
  647.  
  648.   context.mask = (LOW_MASK (((nbits - 1) % (CHAR_BIT)) + 1));
  649.   context.source_ptr =
  650.     ((unsigned char *)
  651.      (MEMORY_LOC (bitstr, (BIT_STRING_INDEX_TO_WORD (bitstr, (nbits - 1))))));
  652.  
  653.   if (ndigits != 0)
  654.   {
  655.     skip = ((sizeof (SCHEME_OBJECT)) -
  656.         (((ndigits - 1) % (sizeof (SCHEME_OBJECT))) + 1));
  657.     while ((--skip) >= 0)
  658.     {
  659.       DEC_BIT_STRING_PTR (context.source_ptr);
  660.     }
  661.   }
  662.  
  663.   return
  664.     (digit_stream_to_bignum (ndigits, bstb_producer,
  665.                  (&context), (1L << CHAR_BIT),
  666.                  0));
  667. }
  668.  
  669. DEFINE_PRIMITIVE ("UNSIGNED-INTEGER->BIT-STRING", Prim_unsigned_to_bit_string, 2, 2, 
  670.  "(LENGTH INTEGER)\n\
  671. INTEGER, which must be a non-negative integer, is converted to \
  672. a bit-string of length LENGTH.  If INTEGER is too large, an \
  673. error is signalled.")
  674. {
  675.   fast long length;
  676.   fast SCHEME_OBJECT object;
  677.   PRIMITIVE_HEADER (2);
  678.   length = (arg_nonnegative_integer (1));
  679.   object = (ARG_REF (2));
  680.   if (FIXNUM_P (object))
  681.     {
  682.       if (FIXNUM_NEGATIVE_P (object))
  683.     error_bad_range_arg (2);
  684.       PRIMITIVE_RETURN
  685.     (long_to_bit_string
  686.      (length, (UNSIGNED_FIXNUM_TO_LONG (object))));
  687.     }
  688.   if (BIGNUM_P (object))
  689.     PRIMITIVE_RETURN (bignum_to_bit_string (length, object));
  690.   error_wrong_type_arg (2);
  691.   /*NOTREACHED*/
  692.   return (0);
  693. }
  694.  
  695. /*  */
  696.  
  697. DEFINE_PRIMITIVE ("BIT-STRING->UNSIGNED-INTEGER", Prim_bit_string_to_unsigned, 1, 1,
  698.  "(BIT-STRING)\n\
  699. BIT-STRING is converted to the appropriate non-negative integer. \
  700. This operation is the inverse of `unsigned-integer->bit-string'.")
  701. {
  702.   fast SCHEME_OBJECT bit_string, *scan;
  703.   long nwords, nbits, word;
  704.   PRIMITIVE_HEADER (1);
  705.   CHECK_ARG (1, BIT_STRING_P);
  706.   bit_string = (ARG_REF (1));
  707.   /* Count the number of significant bits.*/
  708.   scan = (BIT_STRING_HIGH_PTR (bit_string));
  709.   nbits = ((BIT_STRING_LENGTH (bit_string)) % OBJECT_LENGTH);
  710.   word =
  711.     ((nbits > 0)
  712.      ? ((* (DEC_BIT_STRING_PTR (scan))) & (LOW_MASK (nbits)))
  713.      : (* (DEC_BIT_STRING_PTR (scan))));
  714.   for (nwords = ((VECTOR_LENGTH (bit_string)) - 1); (nwords > 0); nwords -= 1)
  715.     {
  716.       if (word != 0)
  717.     break;
  718.       word = (* (DEC_BIT_STRING_PTR (scan)));
  719.     }
  720.   if (nwords == 0)
  721.     PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
  722.   nbits = (((nwords - 1) * OBJECT_LENGTH) + (long_significant_bits (word)));
  723.   PRIMITIVE_RETURN
  724.     ((nbits <= FIXNUM_LENGTH)
  725.      ? (LONG_TO_UNSIGNED_FIXNUM (word))
  726.      : (bit_string_to_bignum (nbits, bit_string)));
  727. }
  728.  
  729. #define READ_BITS_INITIALIZE()                        \
  730.   SCHEME_OBJECT bit_string;                        \
  731.   long end, end_mod, offset;                        \
  732.   SCHEME_OBJECT *start;                            \
  733.   PRIMITIVE_HEADER (3);                            \
  734.   CHECK_ARG (3, BIT_STRING_P);                        \
  735.   bit_string = (ARG_REF (3));                        \
  736.   end = (BIT_STRING_LENGTH (bit_string));                \
  737.   end_mod = (end % OBJECT_LENGTH);                    \
  738.   offset = (arg_nonnegative_integer (2));                \
  739.   start = (READ_BITS_PTR ((ARG_REF (1)), offset, end));            \
  740.   COMPUTE_READ_BITS_OFFSET (offset, end)
  741.  
  742.  
  743. DEFINE_PRIMITIVE ("READ-BITS!", Prim_read_bits_x, 3, 3,
  744.  "(POINTER OFFSET BIT-STRING)\n\
  745. Read the contents of memory at the address (POINTER,OFFSET) into BIT-STRING.")
  746. {
  747.   READ_BITS_INITIALIZE ();
  748.   copy_bits (start,
  749.          offset,
  750.          (MEMORY_LOC
  751.           (bit_string,
  752.            (BIT_STRING_INDEX_TO_WORD (bit_string, (end - 1))))),
  753.          ((end_mod == 0) ? 0 : (OBJECT_LENGTH - end_mod)),
  754.          end);
  755.   PRIMITIVE_RETURN (UNSPECIFIC);
  756. }
  757.  
  758. DEFINE_PRIMITIVE ("WRITE-BITS!", Prim_write_bits_x, 3, 3,
  759.  "(POINTER OFFSET BIT-STRING)\n\
  760. Write the contents of BIT-STRING in memory at the address (POINTER,OFFSET).")
  761. {
  762.   READ_BITS_INITIALIZE ();
  763.   copy_bits ((MEMORY_LOC
  764.           (bit_string,
  765.            (BIT_STRING_INDEX_TO_WORD (bit_string, (end - 1))))),
  766.          ((end_mod == 0) ? 0 : (OBJECT_LENGTH - end_mod)),
  767.          start,
  768.          offset,
  769.          end);
  770.   PRIMITIVE_RETURN (UNSPECIFIC);
  771. }
  772.  
  773. /* Search Primitives */
  774.  
  775. #define SUBSTRING_FIND_INITIALIZE()                    \
  776.   SCHEME_OBJECT bit_string;                        \
  777.   long start, end;                            \
  778.   long word, bit, end_word, end_bit, mask;                \
  779.   SCHEME_OBJECT *scan;                            \
  780.   PRIMITIVE_HEADER (3);                            \
  781.   CHECK_ARG (1, BIT_STRING_P);                        \
  782.   bit_string = (ARG_REF (1));                        \
  783.   start = (arg_nonnegative_integer (2));                \
  784.   end = (arg_nonnegative_integer (3));                    \
  785.   if (end > (BIT_STRING_LENGTH (bit_string)))                \
  786.     error_bad_range_arg (3);                        \
  787.   if (start > end)                            \
  788.     error_bad_range_arg (2);                        \
  789.   if (start == end)                            \
  790.     PRIMITIVE_RETURN (SHARP_F)
  791.  
  792. #define SUBSTRING_FIND_NEXT_INITIALIZE()                \
  793.   SUBSTRING_FIND_INITIALIZE ();                        \
  794.   word = (BIT_STRING_INDEX_TO_WORD (bit_string, start));        \
  795.   bit = (start % OBJECT_LENGTH);                    \
  796.   end_word = (BIT_STRING_INDEX_TO_WORD (bit_string, (end - 1)));    \
  797.   end_bit = (((end - 1) % OBJECT_LENGTH) + 1);                \
  798.   scan = (MEMORY_LOC (bit_string, word))
  799.  
  800. #define FIND_NEXT_SET_LOOP(init_bit)                    \
  801. {                                    \
  802.   bit = (init_bit);                            \
  803.   mask = (1L << (init_bit));                        \
  804.   while (true)                                \
  805.     {                                    \
  806.       if (((BIT_STRING_WORD (scan)) & mask) != 0)            \
  807.     goto win;                            \
  808.       bit += 1;                                \
  809.       mask <<= 1;                            \
  810.     }                                    \
  811. }
  812.  
  813. DEFINE_PRIMITIVE ("BIT-SUBSTRING-FIND-NEXT-SET-BIT", Prim_bitstr_find_next_set_bit, 3, 3,
  814.   "(BIT-STRING START END)")
  815. {
  816.   SUBSTRING_FIND_NEXT_INITIALIZE ();
  817.   if (word == end_word)
  818.     {
  819.       if ((((end_bit - bit) == OBJECT_LENGTH) &&
  820.        ((BIT_STRING_WORD (scan)) != 0)) ||
  821.       (((BIT_STRING_WORD (scan)) & (ANY_MASK ((end_bit - bit), bit)))
  822.        != 0))
  823.     {
  824.       FIND_NEXT_SET_LOOP (bit);
  825.     }
  826.       PRIMITIVE_RETURN (SHARP_F);
  827.     }
  828.   else if (((BIT_STRING_WORD (scan)) &
  829.         ((bit == 0) ? (~ 0) : (ANY_MASK ((OBJECT_LENGTH - bit), bit))))
  830.        != 0)
  831.     {
  832.       FIND_NEXT_SET_LOOP (bit);
  833.     }
  834.   INC_BIT_STRING_PTR (word);
  835.   while (word != end_word)
  836.   {
  837.     if ((* (INC_BIT_STRING_PTR (scan))) != 0)
  838.       {
  839.     FIND_NEXT_SET_LOOP (0);
  840.       }
  841.     INC_BIT_STRING_PTR (word);
  842.   }
  843.   if (((* (INC_BIT_STRING_PTR (scan))) &
  844.        ((end_bit == OBJECT_LENGTH) ? (~ 0) : (LOW_MASK (end_bit))))
  845.       != 0)
  846.     {
  847.       FIND_NEXT_SET_LOOP (0);
  848.     }
  849.   PRIMITIVE_RETURN (SHARP_F);
  850.  win:
  851.   PRIMITIVE_RETURN
  852.     (LONG_TO_UNSIGNED_FIXNUM
  853.      (BIT_STRING_INDEX_PAIR_TO_INDEX (bit_string, word, bit)));
  854. }
  855.  
  856. extern void EXFUN (bit_string_set, (SCHEME_OBJECT, long, int));
  857.  
  858. void
  859. DEFUN (bit_string_set, (bitstr, index, value),
  860.        SCHEME_OBJECT bitstr AND long index AND int value)
  861. {
  862.   unsigned long mask;
  863.   SCHEME_OBJECT * ptr;
  864.  
  865.   ptr = (MEMORY_LOC (bitstr, (BIT_STRING_INDEX_TO_WORD (bitstr, index))));
  866.   mask = (1L << (index % OBJECT_LENGTH));
  867.   if (value == 0)
  868.     (BIT_STRING_WORD (ptr)) &= (~mask);
  869.   else
  870.     (BIT_STRING_WORD (ptr)) |= mask;
  871.   return;
  872. }
  873.