⟦11aaeda2f⟧

TextFile

/*          Hey EMACS, this is -*- C -*- code!                 */

/****************************************************************
*                                                               *
*                         Copyright (c) 1984                    *
*               Massachusetts Institute of Technology           *
*                                                               *
* This material was developed by the Scheme project at the      *
* Massachusetts Institute of Technology, Department of          *
* Electrical Engineering and Computer Science.  Permission to   *
* copy this software, to redistribute it, and to use it for any *
* purpose is granted, subject to the following restrictions and *
* understandings.                                               *
*                                                               *
* 1. Any copy made of this software must include this copyright *
* notice in full.                                               *
*                                                               *
* 2. Users of this software agree to make their best efforts (a)*
* to return to the MIT Scheme project any improvements or       *
* extensions that they make, so that these may be included in   *
* future releases; and (b) to inform MIT of noteworthy uses of  *
* this software.                                                *
*                                                               *
* 3.  All materials developed as a consequence of the use of    *
* this software shall duly acknowledge such use, in accordance  *
* with the usual standards of acknowledging credit in academic  *
* research.                                                     *
*                                                               *
* 4. MIT has made no warrantee or representation that the       *
* operation of this software will be error-free, and MIT is     *
* under no obligation to provide any services, by way of        *
* maintenance, update, or otherwise.                            *
*                                                               *
* 5.  In conjunction with products arising from the use of this *
* material, there shall be no use of the name of the            *
* Massachusetts Institute of Technology nor of any adaptation   *
* thereof in any advertising, promotional, or sales literature  *
* without prior written consent from MIT in each case.          *
*                                                               *
****************************************************************/
\f


/* File: BITSTR.C
 *
 * Bit String support
 */

#include "scheme.h"
#include "primitive.h"

Built_In_Primitive(Prim_Equal_Bit_String, 2, "EQUAL-BIT-STRING?")
{ Primitive_2_Args();
  Arg_1_Type(TC_BIT_STRING);
  Arg_2_Type(TC_BIT_STRING);
  if (Arg1 == Arg2) return TRUTH;
  else
    { if (Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT) ==
	  Fast_Vector_Ref(Arg2, NM_ENTRY_COUNT))
        { long *String1, *String2, i, Offset, Count, Mask;
          Offset = Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT) % POINTER_LENGTH;
          Count = (Get_Integer(Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)) +
		  POINTER_LENGTH-1)/POINTER_LENGTH-1;
          String1 = (long *) Nth_Vector_Loc(Arg1, NM_DATA);
          String2 = (long *) Nth_Vector_Loc(Arg2, NM_DATA);
          for(i=0; i<Count; i++) 
            if(*String1++ != *String2++) return NIL;
          Mask = (1 << Offset)-1;
          if((*String1 & Mask) == (*String2 & Mask)) return TRUTH;
          else return NIL;
        }
      else return NIL;
    }
}
\f


/* (MAKE-FILLED-BIT-STRING size initialization)
   [Primitive number 0xD2] 
   Returns a bit string of the specified size with all the bits
   set to the specified initialization.  The initialization must be
   1 or 0.
*/
#define FULL_POINTER	((Pointer) -1)
#define EMPTY_POINTER	((Pointer) 0)

Built_In_Primitive(Prim_Make_Fld_Bit_String, 2, "MAKE-FILLED-BIT-STRING")
{ long Count, Fill_Word, Bit, i;
  Primitive_2_Args();
  Arg_1_Type(TC_FIXNUM);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Bit, Arg2, 0, 1, ERR_ARG_2_BAD_RANGE);
  Count = (Get_Integer(Arg1)+POINTER_LENGTH-1)/POINTER_LENGTH;
	/* Pointers needed */
  Primitive_GC_If_Needed(Free+Count+1+NM_HEADER_LENGTH);
  Free[NM_VECTOR_HEADER] = 
    Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Count+NM_HEADER_LENGTH-1);
  Free[NM_ENTRY_COUNT] = Get_Integer(Arg1);
  if (Bit == 1) Fill_Word = FULL_POINTER;
  else Fill_Word = EMPTY_POINTER;
  Free += NM_HEADER_LENGTH;
  for (i=0; i < Count; i++) *Free++ = Fill_Word;
  return Make_Pointer(TC_BIT_STRING, Free-(Count+NM_HEADER_LENGTH));
}

\f


/*(MAKE-UNFILLED-BIT-STRING size)
   [Primitive number 0xD1]
   Returns an uninitialized bit string of the size given.
*/
Built_In_Primitive(Prim_Make_Unfilled_Bit_String, 1,
		 "MAKE-UNFILLED-BIT-STRING")
{ long Count, Bit, i;
  Primitive_1_Arg();
  Arg_1_Type(TC_FIXNUM);
  Count = (Get_Integer(Arg1)+POINTER_LENGTH-1)/POINTER_LENGTH;
	/* Pointers needed */
  Primitive_GC_If_Needed(Free+Count+1+NM_HEADER_LENGTH);
  Free[NM_VECTOR_HEADER] = 
    Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Count+NM_HEADER_LENGTH-1);
  Free[NM_ENTRY_COUNT] = Get_Integer(Arg1);
  Free += Count+NM_HEADER_LENGTH;
  return Make_Pointer(TC_BIT_STRING, Free-(Count+NM_HEADER_LENGTH));
}
\f


/*(INSERT-BIT-STRING bitstring1 index bitstring2)
   [Primitive number 0xDA] 
   Creates a new bit string which is the append of
   (BIT-SUBSTRING bitstring1 0 index)
   bitstring2
   (BIT-SUBSTRING bitstring1 index (BIT-STRING-SIZE bitstring1))
   That is, it squeezes  bitstring2 into bitstring1 starting at index.
*/

Built_In_Primitive(Prim_Ins_BStr, 3, "INSERT-BIT-STRING")
{ long Size_Needed, *Old_String, *New_String, *Orig_Free,
       Offset, i, Longword_Offset, new_size;
  Primitive_3_Args();
  Arg_1_Type(TC_BIT_STRING);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_BIT_STRING);
  Range_Check(Offset, Arg2, 0, Vector_Ref(Arg1, NM_ENTRY_COUNT),
              ERR_ARG_2_BAD_RANGE);
  new_size = Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT) +
             Fast_Vector_Ref(Arg3, NM_ENTRY_COUNT);
  Size_Needed =
     (new_size+POINTER_LENGTH-1)/POINTER_LENGTH
                                + NM_HEADER_LENGTH;
	/* Pointers needed */
  Primitive_GC_If_Needed(Free+Size_Needed);
  Free[NM_ENTRY_COUNT] = new_size;
  Free[NM_VECTOR_HEADER] = 
    Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Size_Needed-1);
  Offset %=  POINTER_LENGTH;
  Longword_Offset = Get_Integer(Arg2)/POINTER_LENGTH;
  Old_String = (long *) Nth_Vector_Loc(Arg1, NM_DATA);
  New_String = (long *) Nth_Vector_Loc(Arg3, NM_DATA);
  Orig_Free = (long *) Free;
  Free += NM_DATA;
  for(i=0; i<Longword_Offset; i++) *Free++ = *Old_String++;
  *Free = *Old_String;
  Shift_Bit_String(New_String, &Free,0, &Offset,
                   Fast_Vector_Ref(Arg3, NM_ENTRY_COUNT));
  Shift_Bit_String(Old_String, &Free,
		   Get_Integer(Arg2)%POINTER_LENGTH, &Offset,
		   Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)-Get_Integer(Arg2));
  Free++;
  return Make_Pointer(TC_BIT_STRING,Orig_Free);
}
\f


/* (INSERT-BIT-STRING! bitstring1 index bitstring2)
   [Primitive number 0xDB] 
   Like INSERT-STRING except this side effects bitstring1 to contain
   the same bits as bitstring2, starting at index in bitstring1.
*/
Built_In_Primitive(Prim_Ins_BStr_Excl, 3, "INSERT-BIT-STRING!")
{ long Size_Needed, *Old_String, *New_String, *Orig_Free,
       Offset, Longword_Offset;
  Primitive_3_Args();
  Arg_1_Type(TC_BIT_STRING);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_BIT_STRING);
  Range_Check(Offset, Arg2, 0, Vector_Ref(Arg1, NM_ENTRY_COUNT-1),
              ERR_ARG_2_BAD_RANGE);
  if (Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT) <
      (Fast_Vector_Ref(Arg3, NM_ENTRY_COUNT) + Get_Integer(Arg2)))
    Primitive_Error(ERR_ARG_2_BAD_RANGE);
  Offset %=  POINTER_LENGTH;
  Longword_Offset = Get_Integer(Arg2)/POINTER_LENGTH;
  Old_String = (long *) Nth_Vector_Loc(Arg1, NM_DATA);
  New_String = (long *) Nth_Vector_Loc(Arg3, NM_DATA);
  Old_String += Longword_Offset;
  Shift_Bit_String(New_String, &Old_String, 0, &Offset,
		   Fast_Vector_Ref(Arg3, NM_ENTRY_COUNT));
  return Arg1;
}
\f


/*(READ-BITS address offset count)
   [Primitive number 0xDF]
   Returns a bit string of length count resulting from reading
   memory starting at address plus the bit offset supplied.  Address 
   is a FIXNUM (ADDRESS).
   offset and Count are FIXNUMs.
*/

Built_In_Primitive(Prim_Read_Bits, 3, "READ-BITS")
{ long Count, *Source, Dest_Offset, Source_Offset;
  Pointer  *Orig_Free;
  Primitive_3_Args();
  Arg_1_Type(TC_ADDRESS);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_FIXNUM);
  Count = (Get_Integer(Arg3)+POINTER_LENGTH-1)/POINTER_LENGTH;
	/* Pointers needed */
  Primitive_GC_If_Needed(Free+Count+1+NM_HEADER_LENGTH);
  Free[NM_VECTOR_HEADER] = 
    Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Count+NM_HEADER_LENGTH-1);
  Free[NM_ENTRY_COUNT] = Get_Integer(Arg3);
  Orig_Free = Free;
  Free += NM_HEADER_LENGTH;
  Source = (long *) Get_Integer(Arg1);
  Source_Offset = Get_Integer(Arg2);
  Source += Source_Offset/POINTER_LENGTH;
  Source_Offset %= POINTER_LENGTH;
  Dest_Offset = 0;
  Shift_Bit_String(Source, &Free, Source_Offset,
                   &Dest_Offset, Get_Integer(Arg3));
  Free += 1;
  return Make_Pointer(TC_BIT_STRING, Orig_Free);
}
\f


/* (BIT-STRING-REF bitstring index)
   [Primitive number 0xD5]
   Returns 1 or 0 coresponding to the bit addressed.  Bits are indexed
   from 0.
*/

Built_In_Primitive(Prim_BSt_Ref, 2, "BIT-STRING-REF")
{ long  Word_No, Offset, Mask, *Data_Start;
  Primitive_2_Args();
  Arg_1_Type(TC_BIT_STRING);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2, 0, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)-1,
              ERR_ARG_2_BAD_RANGE);
  Data_Start = (long *) Nth_Vector_Loc(Arg1, NM_DATA);
  Word_No = Offset/POINTER_LENGTH;
  Mask = 1 << Offset % POINTER_LENGTH;
  if ((Data_Start[Word_No] & Mask) != 0) return FIXNUM_0+1;
  else return FIXNUM_0;
}

/* (BIT-STRING-SET! bitstring index value)
   [Primitive number 0xD6]
   Side effects the indexed bit in bitstring to be value. Value must
   be 1 or 0.   Bits are indexed from 0.
*/

Built_In_Primitive(Prim_BSt_Set, 3, "BIT-STRING-SET!")
{ long  Value, Word_No, Offset, Mask, *Data_Start;
  Primitive_3_Args();
  Arg_1_Type(TC_BIT_STRING);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2, 0, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)-1,
              ERR_ARG_2_BAD_RANGE);
  Range_Check(Value, Arg3, 0, 1, ERR_ARG_3_BAD_RANGE);
  Data_Start = (long *) Nth_Vector_Loc(Arg1, NM_DATA);
  Word_No = Offset/POINTER_LENGTH;
  Mask = 1 << Offset % POINTER_LENGTH;
  if ((Data_Start[Word_No] & Mask) != 0)
    { if (!Value) Data_Start[Word_No] &= ~Mask;
      return FIXNUM_0+1;
    }
  else 
    { if (Value) Data_Start[Word_No] |= Mask;
      return FIXNUM_0;
    }
}
\f


/* (BIT-STRING-SET-FALSE! bitstring index)
   [Primitive number 0xD8]   
   Side effects the indexed bit in bitstring to be a logical FALSE.
   Bits are indexed from 0.
*/

Built_In_Primitive(Prim_BSt_Set_False, 2, "BIT-STRING-SET-FALSE!")
{ long  Value, Word_No, Offset, Mask, *Data_Start;
  Primitive_2_Args();
  Arg_1_Type(TC_BIT_STRING);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2, 0, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)-1,
              ERR_ARG_2_BAD_RANGE);
  Data_Start = (long *) Nth_Vector_Loc(Arg1, NM_DATA);
  Word_No = Offset/POINTER_LENGTH;
  Mask = 1 << Offset % POINTER_LENGTH;
  if ((Data_Start[Word_No] & Mask) != 0)
    { Data_Start[Word_No] &= ~Mask;
      return FIXNUM_0+1;
    }
  return FIXNUM_0;
}

/*(BIT-STRING-SET-TRUE! bitstring index)
   [Primitive number 0xD7]
   Side effects the indexed bit in bitstring to be a logical TRUE.
   Bits are indexed from 0.
*/

Built_In_Primitive(Prim_BSt_Set_True, 2, "BIT-STRING-SET-TRUE!")
{ long  Value, Word_No, Offset, Mask, *Data_Start;
  Primitive_2_Args();
  Arg_1_Type(TC_BIT_STRING);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2, 0, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)-1,
              ERR_ARG_2_BAD_RANGE);
  Data_Start = (long *) Nth_Vector_Loc(Arg1, NM_DATA);
  Word_No = Offset/POINTER_LENGTH;
  Mask = 1 << Offset % POINTER_LENGTH;
  if ((Data_Start[Word_No] & Mask) == 0)
    { Data_Start[Word_No] |= Mask;
      return FIXNUM_0;
    }
  return FIXNUM_0+1;
}
\f


/* (BIT-STRING-SIZE bitstring)
   [Primitive number 0xD4]
   Returns the number of bits in bitstring.
*/
Built_In_Primitive(Prim_BSt_Size, 1, "BIT-STRING-SIZE")
{ Primitive_1_Arg();
  Arg_1_Type(TC_BIT_STRING);
  return Make_Non_Pointer(TC_FIXNUM, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT));
}

/*(BIT-STRING? object)
   [Primitive number 0xD3]  
   Returns #!TRUE if object is a bit string, otherwise #!FALSE.
*/
Built_In_Primitive(Prim_BSt_Qm, 1, "BIT-STRING?")
{ Primitive_1_Arg();
  Touch_In_Primitive(Arg1, Arg1);
  return (Type_Code(Arg1) == TC_BIT_STRING) ? TRUTH : NIL;
}
\f


/* (BIT-SUBSTRING bitstring low high)
   [Primitive number 0xD9]  
   Returns a bit string whose bits consist of bits low through bit
   high-1 of the given bitstring.
*/

Built_In_Primitive(Prim_Bit_Substring, 3, "BIT-SUBSTRING")
{ long Start, End, Offset, Count, i, Mask, Right_Shift, Dest_Offset,
       *Orig_Free;
  Pointer *Finger;
  Primitive_3_Args();
  Arg_1_Type(TC_BIT_STRING);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_FIXNUM);
  Range_Check(Start, Arg2, 0, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT),
              ERR_ARG_2_BAD_RANGE);
  Range_Check(End, Arg3, Start, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT),
              ERR_ARG_3_BAD_RANGE);
  Count = (End-Start+POINTER_LENGTH-1)/POINTER_LENGTH;
       /* Number of Pointers needed */
  Primitive_GC_If_Needed(Free+Count+NM_HEADER_LENGTH +1);
  /* The + 1 in the GC macro is because we add one to free in the end */
  Free[NM_VECTOR_HEADER] = 
    Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Count+NM_HEADER_LENGTH-1);
  Free[NM_ENTRY_COUNT] = End-Start;
  Offset = Start % POINTER_LENGTH;
       /* The bit index in first Pointer of substring */
  Dest_Offset = 0;
  Finger = Nth_Vector_Loc(Arg1, NM_DATA) + Start/POINTER_LENGTH;
       /* C-pointer to the first Pointer of substring numbered from 0 */
  Orig_Free = (long *) Free;
  Free += NM_HEADER_LENGTH;
  Shift_Bit_String(Finger,&Free,Offset,&Dest_Offset,End-Start);
  Free++;
  return Make_Pointer(TC_BIT_STRING, Orig_Free);
}
\f


/*(REVERSE-BIT-STRING bstring)
  [primitive 0xDE]
  Makes a new bitstring consisting of the bits in the bitstring
  supplied in reverse order.
*/
Built_In_Primitive(Prim_Reverse_Bit_String, 1, "REVERSE-BIT-STRING")
{ long Count, Inner_Count, Remainder_Bits, Starting_Source_Mask,
       *Orig_Free, Starting_Dest_Mask, *Source, *Dest, i, j;
  fast long Source_Mask, Dest_Mask;
  Primitive_1_Arg();
  Arg_1_Type(TC_BIT_STRING);
  Primitive_GC_If_Needed(Free + Fast_Vector_Ref(Arg1, NM_VECTOR_HEADER) + 1);
  Free[NM_VECTOR_HEADER] = Fast_Vector_Ref(Arg1, NM_VECTOR_HEADER);
  Free[NM_ENTRY_COUNT] = Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT);
  Count = Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)/POINTER_LENGTH;
  Remainder_Bits = Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT) % POINTER_LENGTH;
  Dest = (long *) Free;
  Dest += NM_DATA;
  Source = (long *) Nth_Vector_Loc(Arg1, NM_DATA+Count);

  if(Remainder_Bits > 0)
    { Starting_Source_Mask = (1 << (Remainder_Bits-1));
      Source_Mask = Starting_Source_Mask;
      Starting_Dest_Mask = (Starting_Source_Mask << 1);
    }
  else
     { Starting_Source_Mask = HIGH_BIT;
       Source_Mask = Starting_Source_Mask;
       Starting_Dest_Mask = 1;
     }

/* Prim_Reverse_Bit_String continues on the next page */
\f


/* Prim_Reverse_Bit_String, continued */

  *Dest = 0;
  Dest_Mask = 1;
  for(i=0; i<Remainder_Bits; i++)
    { if((*Source & Source_Mask) != 0)
        *Dest |= Dest_Mask;
      Dest_Mask = (Dest_Mask << 1);
      Source_Mask = (Source_Mask >> 1);
    }
  Inner_Count = POINTER_LENGTH-Remainder_Bits-1;
  for(i=0; i<Count; i++)
     { Source_Mask = HIGH_BIT;
       Dest_Mask = Starting_Dest_Mask;
       Source--;
       if((*Source & Source_Mask) != 0) /* sign bit is copied on right-shift */
         *Dest |= Dest_Mask;
       Dest_Mask = (Dest_Mask << 1);
       Source_Mask = (Source_Mask >> 1) & ~Source_Mask;
       for(j=0; j<Inner_Count; j++)
         { if((*Source & Source_Mask) != 0)
             *Dest |= Dest_Mask;
           Dest_Mask = (Dest_Mask << 1);
           Source_Mask = (Source_Mask >> 1);
         }
       *++Dest = 0;
       Source_Mask = Starting_Source_Mask;
       Dest_Mask = 1;
       for(j=0; j<Remainder_Bits; j++)
         { if((*Source & Source_Mask) != 0)
             *Dest |= Dest_Mask;
           Dest_Mask = (Dest_Mask << 1);
           Source_Mask = (Source_Mask >> 1);
         }
     }
  Orig_Free = (long * ) Free;
  Free += Get_Integer(Free[NM_VECTOR_HEADER]) + 1;
  return Make_Pointer(TC_BIT_STRING,  Orig_Free);
}
\f


/* (VECTOR-1B? OBJECT)
      [Primitive number 0x9E]
      Returns #!TRUE if OBJECT is a bit-vector as created by
      VECTOR_1B_CONS.
*/
Built_In_Primitive(Prim_Vector_1b, 1, "VECTOR-1B")
{ Primitive_1_Arg();
  Touch_In_Primitive(Arg1, Arg1);
  return (Type_Code(Arg1) == TC_VECTOR_1B) ? TRUTH : NIL;
}

/* (VECTOR_1B_CONS LENGTH)
      [Primitive number 0x9D]
      Creates an uninitialized bit vector large enough to hold LENGTH
      bits.
*/
Built_In_Primitive(Prim_Vector_1b_Cons, 1, "VECTOR-1B-CONS")
{ long Size_Needed;
  Primitive_1_Arg();
  Arg_1_Type(TC_FIXNUM);
  Size_Needed = (Get_Integer(Arg1)+7)/8;
	/* Bytes needed */
  Size_Needed =
    (Size_Needed*sizeof(char)) / sizeof(Pointer) +
    1 + NM_HEADER_LENGTH;
	/* Pointers needed */
  Primitive_GC_If_Needed(Free+Size_Needed);
  Free[NM_VECTOR_HEADER] = 
    Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Size_Needed-1);
  Free[NM_ENTRY_COUNT] = Arg1;
  Free += Size_Needed;
  return Make_Pointer(TC_VECTOR_1B, Free-Size_Needed);
}
\f


/* (VECTOR_1B_REF BIT-VECTOR OFFSET)
      [Primitive number 0x9F]
      Return #!TRUE if the OFFSETth bit in BIT-VECTOR is set, or NIL
      otherwise.  Bits are numbered from 0.
*/
Built_In_Primitive(Prim_Vector_1b_Ref, 2, "VECTOR-1B-REF")
{ long Offset, Char_No, Mask;
  char *Data_Start;
  Primitive_2_Args();
  Arg_1_Type(TC_VECTOR_1B);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2, 0, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)-1,
              ERR_ARG_2_BAD_RANGE);
  Char_No = Offset / 8;
  Mask = 1 << (Offset % 8);
  Data_Start = (char *) Nth_Vector_Loc(Arg1, NM_DATA);
  if ((Data_Start[Char_No] & Mask) != 0)
    return TRUTH;
  else return NIL;
}
\f


/* (VECTOR_1B_SET BIT-VECTOR OFFSET VALUE)
      [Primitive number 0xA0]
      Sets the OFFSETth bit in BIT-VECTOR to VALUE, which must be
      either #!TRUE or NIL.  Returns (bad style to rely on this)
      previous value. Bits are numbered from 0.
*/
Built_In_Primitive(Prim_Vec_1b_Set, 3, "VECTOR-1B-SET!")
{ long Offset, Char_No, Mask;
  char *Data_Start;
  Boolean Value;
  Pointer Result;
  Primitive_3_Args();
  Arg_1_Type(TC_VECTOR_1B);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2, 0, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)-1,
              ERR_ARG_2_BAD_RANGE);
  if (Arg3 == NIL) Value = false;
  else if (Arg3 == TRUTH) Value = true;
  else Primitive_Error(ERR_ARG_3_WRONG_TYPE);
  Char_No = Offset / 8;
  Mask = 1 << (Offset % 8);
  Data_Start = (char *) Nth_Vector_Loc(Arg1, NM_DATA);
  if ((Data_Start[Char_No] & Mask) != 0)
    Result = TRUTH;
  else Result = NIL;
  if (Value) Data_Start[Char_No] |= Mask;
  else Data_Start[Char_No] &= ~Mask;
  return Result;
}

/* (VECTOR_1B_SIZE BIT-VECTOR)
      [Primitive number 0xAC]
      Returns the number of bits in BIT-VECTOR.
*/
Built_In_Primitive(Prim_Vec_1b_Size, 1, "VECTOR-1B-SIZE")
{ Primitive_1_Arg();
  Arg_1_Type(TC_VECTOR_1B);
  return Make_Non_Pointer(TC_FIXNUM, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT));
}
\f


/* (VEC_1B_SET_FALSE VECTOR OFFSET)
      [Primitive number 0xA1]
      (VEC_1B_SET_FALSE V O) is the same as (VECTOR_1B_SET V O NIL)
*/
Built_In_Primitive(Prim_1b_Set_False, 2, "VECTOR-1B-SET-FALSE!")
{ long Offset, Char_No, Mask;
  char *Data_Start;
  Pointer Result;
  Primitive_2_Args();
  Arg_1_Type(TC_VECTOR_1B);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2, 0, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)-1,
              ERR_ARG_2_BAD_RANGE);
  Char_No = Offset / 8;
  Mask = 1 << (Offset % 8);
  Data_Start = (char *) Nth_Vector_Loc(Arg1, NM_DATA);
  if ((Data_Start[Char_No] & Mask) != 0)
    Result = TRUTH;
  else Result = NIL;
  Data_Start[Char_No] &= ~Mask;
  return Result;
}

/* (VEC_1B_SET_TRUE
      [Primitive number 0xA2]
      (VEC_1B_SET_FALSE V O) is the same as (VECTOR_1B_SET V O #!TRUE)
*/
Built_In_Primitive(Prim_1b_Set_True, 2, "VECTOR-1B-SET-TRUE!")
{ long Offset, Char_No, Mask;
  char *Data_Start;
  Pointer Result;
  Primitive_2_Args();
  Arg_1_Type(TC_VECTOR_1B);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2, 0, Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT)-1,
              ERR_ARG_2_BAD_RANGE);
  Char_No = Offset / 8;
  Mask = 1 << (Offset % 8);
  Data_Start = (char *) Nth_Vector_Loc(Arg1, NM_DATA);
  if ((Data_Start[Char_No] & Mask) != 0)
    Result = TRUTH;
  else Result = NIL;
  Data_Start[Char_No] |= Mask;
  return Result;
}
\f


/*(WRITE-BITS! address offset bitstring)
   [Primitive number 0xE0]
   Starting at the address in memory supplied, and the bit offset,
   OFFSET supplied, the bits in bitstring
   are written over what was there.  This is a low level mutator.
*/

Built_In_Primitive(Prim_Write_Bits, 3, "WRITE-BITS!")
{ long *Source, *Dest, Offset, Bits;
  Primitive_3_Args();
  Arg_1_Type(TC_ADDRESS);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_BIT_STRING);
  Source = (long *) Nth_Vector_Loc(Arg3, NM_DATA);
  Dest = (long *) Get_Integer(Arg1);
  Bits = Fast_Vector_Ref(Arg3, NM_ENTRY_COUNT);
  Offset = Get_Integer(Arg2);
  Dest += Offset/POINTER_LENGTH;
  Offset %= POINTER_LENGTH;
  Shift_Bit_String(Source, &Dest, 0, &Offset, Bits);
  return TRUTH;
}
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦11aaeda2f⟧ TextFile

Derivation

TextFile
