⟦cb9138921⟧

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: STRING.C
 *
 * Support for strings and conversion to and from lists of characters.
 */

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

                    /****************************/
                    /* Making Character Strings */
                    /****************************/

#define Empty_String()						\
  Pointer_Count = 2 + 1 + (Get_Integer(Arg1)/sizeof(Pointer));	\
  Primitive_GC_If_Needed(Free + Pointer_Count);			\
  Free[STRING_HEADER] =						\
    Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Pointer_Count-1);	\
  Free[STRING_LENGTH] = FIXNUM_0;				\
  /* put a null in first character position */			\
  (*((char *) (Free + STRING_CHARS))) = '\0';			\
  Free += Pointer_Count;

Built_In_Primitive(Prim_Make_Empty_String, 1, "MAKE-EMPTY-STRING")
{ long Pointer_Count;
  Primitive_1_Arg();
  Arg_1_Type(TC_FIXNUM);
  Empty_String();
  return Make_Pointer(TC_CHARACTER_STRING, Free-Pointer_Count);
}
\f

 
Built_In_Primitive(Prim_Make_Fld_String, 2, "MAKE-FILLED-STRING")
{ Pointer Result;
  long C, i, Pointer_Count, Count;
  char *P;
  Primitive_2_Args();
  Arg_1_Type(TC_FIXNUM);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(C, Arg2, 0, 255, ERR_ARG_2_BAD_RANGE);
  Empty_String();
  Result = Make_Pointer(TC_CHARACTER_STRING, Free-Pointer_Count);
  P = (char *) Nth_Vector_Loc(Result, STRING_CHARS);
  Count = Get_Integer(Arg1);
  for (i=0; i < Count; i++) *P++ = C;
  *P++ = '\0';				       /* Add null */
  Vector_Set(Result, STRING_LENGTH, FIXNUM_0+Count);
  return Make_Pointer(TC_CHARACTER_STRING, Free-Pointer_Count);
}

/* Bit Blit.  Moves an arbitrary string of bits to an arbitrary place
   Given: Pointer to source string, Pointer to a pointer to
  destination string, Source offset, a pointer to destination offset and
  the number of bits to be moved.  Updates the destination pointer and
  offset.  
*/

#define Down_Shift(Word,Offset) \
          (((Word) >> Offset) & ((1 << (POINTER_LENGTH-Offset))-1))
#define Up_Shift(Word,Offset) \
          ((Word) << Offset)
\f


Shift_Bit_String(Source, Dest_Ptr, Source_Offset,
                 Dest_Offset_Ptr, Bit_Count)
long *Source, **Dest_Ptr, Source_Offset, *Dest_Offset_Ptr, Bit_Count;
{ long Offset, Count, Shift, Mask, i, Remainder_Bits,
       *Dest = *Dest_Ptr, D_Offset = *Dest_Offset_Ptr;
  Offset = Source_Offset-D_Offset;
  if (Offset == 0)
    if(Bit_Count+Source_Offset <= POINTER_LENGTH)
      { Mask=(1 << Bit_Count)-1;
        Mask=(Mask << Source_Offset);
        *Dest = (*Source & Mask) | (*Dest & ~Mask);
        if(Bit_Count+Source_Offset == POINTER_LENGTH) Dest++;
        *Dest_Offset_Ptr = (*Dest_Offset_Ptr+Bit_Count)%POINTER_LENGTH;
        *Dest_Ptr = Dest;
        return;
      }  /* Special Case */
    else
      { Mask = (1 << Source_Offset)-1, Remainder_Bits;
        *Dest = (*Source & ~Mask) | (*Dest & Mask); /* First Word */
        *Dest++; *Source++;
        Count = (Source_Offset+Bit_Count)/32-1;
        Remainder_Bits = (Source_Offset+Bit_Count)%POINTER_LENGTH;
        for(i=0; i<Count; i++) *Dest++ = *Source++;
        Mask = (1 << Remainder_Bits)-1;
        *Dest = (*Source & Mask) | (*Dest & ~Mask);
        *Dest_Offset_Ptr = (*Dest_Offset_Ptr+Bit_Count)%POINTER_LENGTH;
        *Dest_Ptr = Dest;
        return;
      }

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


/* Shift_Bit_String, continued */

  else
    switch(Offset > 0)
      {
        case 1: /* Source_Offset > D_Offset */
          if(D_Offset+Bit_Count <= POINTER_LENGTH)
            { long Temp;
              Mask=(1 << Bit_Count)-1;
              Mask = (Mask << D_Offset);
              Shift = POINTER_LENGTH-Offset;
              Temp=Down_Shift(*Source, Offset);
              if (Source_Offset+Bit_Count > POINTER_LENGTH)
                Temp |= Up_Shift(*++Source,Shift);
              *Dest=(Mask & Temp) | (*Dest & ~Mask);
              if(D_Offset+Bit_Count == POINTER_LENGTH) Dest++;
              D_Offset += Bit_Count%POINTER_LENGTH;
             *Dest_Offset_Ptr = (*Dest_Offset_Ptr+Bit_Count)%POINTER_LENGTH;
             *Dest_Ptr = Dest;
              return;
            }

          else
            { long Count_1, Count_2;
              Mask=(1 << D_Offset)-1;
              *Dest &= Mask;
              *Dest |= Down_Shift(*Source++,Offset) & ~Mask;
                  /* Take care of first word */

               Shift=POINTER_LENGTH-Offset;
               Mask=(1 << Shift)-1;
               Count_1=(Source_Offset+Bit_Count)/POINTER_LENGTH-1;
               Count_2=(D_Offset+Bit_Count)/POINTER_LENGTH-1;
               Remainder_Bits=(D_Offset+Bit_Count)%POINTER_LENGTH;
               if(Count_1 == Count_2)
                 { for(i=0; i<Count_1; i++) /* Middle words */
                     { *Dest++ |= Up_Shift(*Source,Shift);
                       *Dest = (*Source++ >> Offset) & Mask;
                     }
                   *Dest++ |= Up_Shift(*Source,Shift);  /* Last Word(s) */
                   Mask=(1 << Remainder_Bits)-1;
                   *Dest = (Down_Shift(*Source, Offset) & Mask) | 
                           (*Dest & ~Mask);
                 }

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


/* Shift_Bit_String, continued */

               else
                 { for(i=0; i<Count_2; i++) /* Middle words */
                     { *Dest++ |= Up_Shift(*Source,Shift);
                       *Dest = (*Source++ >> Offset) & Mask;
                     }

                   *Dest++ |= Up_Shift(*Source,Shift);  /* Last Word(s) */
                   Mask = (1 << Remainder_Bits)-1;
                   *Dest &= ~Mask;
                   *Dest |= Down_Shift(*Source++,Offset) & Mask;
                   *Dest |= Up_Shift(*Source,Shift) & Mask;
                 }
               *Dest_Offset_Ptr = (*Dest_Offset_Ptr+Bit_Count) %
                                   POINTER_LENGTH;
               *Dest_Ptr = Dest;
               return;
             }
        case 0: /* Source_Offset < D_Offset */
          Offset = -Offset;
          if(D_Offset+Bit_Count <= POINTER_LENGTH)
            { Mask=(1 << Bit_Count)-1;
              Mask=(Mask << D_Offset);
              *Dest = (*Dest & ~Mask) | (Mask & (*Source << Offset));
              if(D_Offset+Bit_Count == POINTER_LENGTH) Dest++;
              D_Offset += Bit_Count%POINTER_LENGTH;
              *Dest_Offset_Ptr = (*Dest_Offset_Ptr+Bit_Count)%POINTER_LENGTH;
              *Dest_Ptr = Dest;
              return;
            }

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


/* Shift_Bit_String, continued */

          else
            { Mask=(1 << D_Offset)-1;
              Shift=POINTER_LENGTH-Offset;
              Remainder_Bits=(D_Offset+Bit_Count)%POINTER_LENGTH;
              *Dest &= Mask;
              *Dest++ |= (*Source << Offset) & ~Mask;
                    /* First Word */
              Mask=(1 << Offset)-1;
              Count= (Bit_Count-(POINTER_LENGTH-D_Offset))/POINTER_LENGTH;
              for(i=0; i<Count; i++)  /* Middle Words */
                { *Dest = (*Source++ >> Shift) & Mask;
                  *Dest++ |= (*Source << Offset);
                }

              if(Remainder_Bits > 0)  /* Last Word patched up */
                { Mask=(1 << Remainder_Bits)-1;
                  *Dest = (Down_Shift(*Source++,Shift) & Mask) | 
                          (*Dest &= ~Mask);
                  *Dest |= Up_Shift(*Source,Offset) & Mask;
                  *Dest_Offset_Ptr = (*Dest_Offset_Ptr+Bit_Count)
                                     % POINTER_LENGTH;
                  *Dest_Ptr = Dest;
                  return;
                }
              else 
                *Dest_Offset_Ptr =
		  (*Dest_Offset_Ptr+Bit_Count)%POINTER_LENGTH;
                *Dest_Ptr = Dest;
                return;
            }
      }
}
\f


/* (BUILD_STRING_FROM_LIST LIST)
      [Primitive number 0x5F]
      Takes a list of the ASCII codes for characters and converts it
      into a string containing those characters.  For example, on
      input '(#/A #/B #/C) it returns "ABC".
*/
Built_In_Primitive(Prim_Build_String_From_List, 1, "BUILD-STRING-FROM-LIST")
{ Pointer Result;
  /* The work is done by Make_String, in file FASLOAD.C */
  Primitive_1_Arg();
  return Make_String(Arg1);
}
\f


/* (EQUAL_STRING_TO_LIST STRING LIST)
      [Primitive number 0x60]
      Compares characters from the string with ASCII character codes from
      the LIST.  Returns #!TRUE if the string and the list have the same
      number of characters and all the characters match.  Returns NIL
      otherwise.
*/
Built_In_Primitive(Prim_Equal_String_To_List, 2, "EQUAL-STRING-TO-LIST")
{ long Count, i;
  char *Next;
  Pointer Next_List;
  Primitive_2_Args();

  Arg_1_Type(TC_CHARACTER_STRING);
  Count = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  Next = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  Touch_In_Primitive(Arg2, Next_List);
  for (i=0; (i < Count) && (Type_Code(Next_List) == TC_LIST); i++)
  { fast Pointer Next_Val;
    Touch_In_Primitive(Vector_Ref(Next_List, CONS_CAR), Next_Val);
    if (Type_Code(Next_Val) != TC_CHARACTER)
      Primitive_Error(ERR_ARG_2_WRONG_TYPE);
    if (*Next++ != Get_Integer(Next_Val)) return NIL;
    Touch_In_Primitive(Vector_Ref(Next_List, CONS_CDR), Next_List);
  }
  if ((i==Count) && (Next_List==NIL)) return TRUTH;
  if ((Next_List != NIL) && (Type_Code(Next_List) != TC_LIST))
    Primitive_Error(ERR_ARG_2_WRONG_TYPE);
  return NIL;
}
\f


/* (INSERT_STRING ORIG-STRING N INSERTION)
      [Primitive number 0x1D]
      ORIG-STRING and INSERTION must be strings.  A new string is
      created which contains INSERTION between the (N-1)st and Nth
      characters of ORIG-STRING.  If N is 0, this is the concatenation
      of INSERTION followed by ORIG-STRING.  If N is (STRING_LENGTH
      ORIG_STRING) it is the concatenation of ORIG-STRING followed by
      INSERTION.  Both strings are copied in the process (i.e. the new
      string never shares characters with the original ones).
*/
Built_In_Primitive(Prim_Insert_String, 3, "INSERT-STRING")
{ char *To, *From_New, *From_Old; 
  long Index, Old_Length, New_Length, Length, i, Pointer_Count;
  Primitive_3_Args();
  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_CHARACTER_STRING);
  Old_Length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  New_Length = Get_Integer(Fast_Vector_Ref(Arg3, STRING_LENGTH));
  Range_Check(Index, Arg2, 0, Old_Length, ERR_ARG_2_BAD_RANGE);
  From_Old = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  From_New = (char *) Nth_Vector_Loc(Arg3, STRING_CHARS);
  To = ((char *) (Free+2));
  if (Old_Length-Index >= New_Length) Length = Old_Length;
  else Length = Old_Length + New_Length;
  Pointer_Count=
    (sizeof(Pointer) + Length*sizeof(char))/ sizeof(Pointer);
  Primitive_GC_If_Needed(Free + Pointer_Count + 1);
  Free[NM_VECTOR_HEADER] =
    Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Pointer_Count+1);
  Free[NM_ENTRY_COUNT] = FIXNUM_0+Length;
  for (i=0; i < Index; i++) *To++ = *From_Old++;
  for (i=0; i < New_Length; i++) *To++ = *From_New++;
  for (i=Index; i < Old_Length; i++) *To++ = *From_Old++;
  *To++ = '\0';		 		 /* Add the null */
  Free += (Pointer_Count + 2);
  return Make_Pointer(TC_CHARACTER_STRING, Free-(Pointer_Count+2));
}
\f


/* (STRING_EQUAL STRING-1 STRING-2)
      [Primitive number 0x0E]
      Compare two strings for equality.  This comparison is
      case-sensitive.
*/
Built_In_Primitive(Prim_String_Equal, 2, "STRING-EQUAL")
{ char *Finger_1, *Finger_2; long Length_1, Length_2, i; 
  Primitive_2_Args();
  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_CHARACTER_STRING);
  Length_1 = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  Length_2 = Get_Integer(Fast_Vector_Ref(Arg2, STRING_LENGTH));
  if (Length_1 != Length_2) return NIL;
  Finger_1 = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  Finger_2 = (char *) Nth_Vector_Loc(Arg2, STRING_CHARS);
  for (i=0; i < Length_1; i++)
    if (*Finger_1++ != *Finger_2++) return NIL;
  return TRUTH;
}
\f


/* (OVERWRITE_STRING ORIG-STRING POSITION NEW-STRING)
      [Primitive number 0x2B]
      Side-effects the ORIG-STRING by replacing characters starting at
      POSITION with characters from NEW-STRING.  If POSITION is 0, the
      replacement is at the start of the string, and so on.  It is not
      possible to extend the length of a string this way unless
      the string contains room for more characters than it currently 
      has, which should be priviledged information. The value returned
      is ORIG-STRING, which will have been modified.
*/
Built_In_Primitive(Prim_Overwrite_String, 3, "OVERWRITE-STRING")
{ char *To, *From;
  long Max_Length, Old_Length, Addition, New_Length, Index, i;
  Primitive_3_Args();
  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_CHARACTER_STRING);
  Max_Length = ((Get_Integer(Fast_Vector_Ref(Arg1, STRING_HEADER)) - 1) *
		(sizeof(Pointer))) - 1;
  Old_Length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  Addition = Get_Integer(Fast_Vector_Ref(Arg3, STRING_LENGTH));
  Index = Get_Integer(Arg2);
  if (Index > Old_Length)
    Primitive_Error(ERR_ARG_2_BAD_RANGE);
  if ((New_Length = Index + Addition) > Max_Length)
    Primitive_Error(ERR_ARG_3_BAD_RANGE);
  From = (char *) Nth_Vector_Loc(Arg3, STRING_CHARS);
  To = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  To += Index;
  for (i=0; i < Addition; i++) *To++ = *From++;
  /* If we have gone past the bounds of the old string,
     add Null and adjust string length.
  */
  if (New_Length > Old_Length)
  { *To++ = '\0';
    Vector_Ref(Arg1, STRING_LENGTH) = FIXNUM_0 + New_Length;
  }
  for (i=0; i < New_Length; i++) *To++ = *From++;
  return Arg1;
}
\f


/* (SUBSTRING STRING FROM TO)
      [Primitive number 0x45]
      Extracts the substring of STRING beginning with the FROMth
      character and continuing to (but not including) the TOth
      character. Thus (SUBSTRING S 0 (STRING_LENGTH S)) returns a copy
      of all of S.
*/
Built_In_Primitive(Prim_Substring, 3, "SUBSTRING")
{ char *To, *From; long Low, High, Length,
       Elements, i, Pointer_Count;
  Primitive_3_Args();
  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_FIXNUM);
  Length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  Range_Check(Low, Arg2, 0, Length, ERR_ARG_2_BAD_RANGE);
  Range_Check(High, Arg3, 0, Length, ERR_ARG_3_BAD_RANGE);
  Elements = High-Low;
  Pointer_Count=
    (sizeof(Pointer) + Elements*sizeof(char))/ sizeof(Pointer);
  Primitive_GC_If_Needed(Free + Pointer_Count + 1);
  Free[0]=Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Pointer_Count+1);
  Free[1]=FIXNUM_0+Elements;
  if (Low > High) Primitive_Error(ERR_ARG_3_BAD_RANGE);
  To = ((char *) (Free+2));
  From = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  From += Low;
  for (i=0; i < Elements; i++) *To++ = *From++;
  *To++ = '\0';			/* Add the null */
  Free += Pointer_Count + 2;
  return Make_Pointer(TC_CHARACTER_STRING, Free-(Pointer_Count+2));
}    
\f


/* (SUBSTRING_SEARCH STRING SUBSTRING)
      [Primitive number 0xB8]
      Returns the character position in STRING where the first
      occurrence of SUBSTRING begins.  The search is case-sensitive.
      Returns NIL if the SUBSTRING does not occur.
*/
Built_In_Primitive(Prim_Substring_Search, 2, "SUBSTRING-SEARCH")
{ char *String, *Sub;
  long String_Length, Sub_Length, Stop_At, i, j;
  Primitive_2_Args();
  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_CHARACTER_STRING);
  String = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  Sub = (char *) Nth_Vector_Loc(Arg2, STRING_CHARS);
  String_Length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  Sub_Length = Get_Integer(Fast_Vector_Ref(Arg2, STRING_LENGTH));
  Stop_At = String_Length-Sub_Length;
  for (i=0; i <= Stop_At; i++)
  { for (j=0; j < Sub_Length; j++)
      if (String[i+j] != Sub[j]) break;
    if (j == Sub_Length) return FIXNUM_0+i;
  }
  return NIL;
}
\f


/* (SUBSTRING_TO_LIST STRING FROM TO)
   [Primitive number 0x4A]
   The same as SUBSTRING, except the result is a list of ASCII
   character codes rather than a string.
   */    
Built_In_Primitive(Prim_Substring_To_List, 3, "SUBSTRING->LIST")
{ char *Finger;
  long Low, High, Length, Elements, i;
  Pointer Result;
  
  Primitive_3_Args();    
  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_FIXNUM);
  Length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  Range_Check(Low, Arg2, 0, (Length == 0)? 0 : Length-1,
              ERR_ARG_2_BAD_RANGE);
  Range_Check(High, Arg3, Low, Length, ERR_ARG_3_BAD_RANGE);
  Elements = High-Low;
  Primitive_GC_If_Needed(Free +  2 * Elements);
  if (Elements==0) return NIL;
  Finger = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  Finger += Low;
  Result = Make_Pointer(TC_LIST, Free);
  for (i=0; i < Elements; i++, Free++)
  { *Free++ = FIXNUM_0+(MAX_CHAR & *Finger++);
    *Free = Make_Pointer(TC_LIST, Free+1);
  }
  Free[-1] = NIL;
  return Result;
}
\f


/* (RAISE_STRING STRING)
      [Primitive number 0xB3]
      Returns a copy of STRING with all lower-case letters changed to
      upper-case.
*/
Built_In_Primitive(Prim_Raise_String, 1, "RAISE-STRING")
{ long Length, Word_Length, i;
  char *From, *To;
  Primitive_1_Arg();
  Arg_1_Type(TC_CHARACTER_STRING);
  Word_Length =
    1 + Get_Integer(Fast_Vector_Ref(Arg1, STRING_HEADER));
  Primitive_GC_If_Needed(Free + Word_Length);
  Length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  Free[STRING_HEADER] = Fast_Vector_Ref(Arg1, STRING_HEADER);
  Free[STRING_LENGTH] = FIXNUM_0+Length;
  From = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  To = (char *) &Free[STRING_CHARS];
  for (i=0; i < Length; i++, From++, To++)
  { fast char c = *From;
    if ((c >= 'a') && (c <= 'z'))
      *To = c-'a'+'A';
    else *To = c;
  }
  *To++ = '\0';			  /* Add the null */
  Free += Word_Length;
  return Make_Pointer(TC_CHARACTER_STRING, Free-Word_Length);
}

/* (RAISE_CHAR CHAR-CODE)
      [Primitive number 0x64]
      If CHAR-CODE is the ASCII code for a lower-case letter, returns
      the ASCII code for the upper-case letter.  Otherwise returns
      CHAR-CODE unchanged.
*/
Built_In_Primitive(Prim_Raise_Char, 1, "RAISE-CHAR")
{ long Value;
  Primitive_1_Arg();
  Arg_1_Type(TC_FIXNUM);
  Range_Check(Value, Arg1, 0, MAX_CHAR, ERR_ARG_1_BAD_RANGE);
  if (Value >= 'a' && Value <= 'z') Value += 'A'-'a';
    return FIXNUM_0+Value;
}
\f


/* (STRING_HASH STRING)
      [Primitive number 0x83]
      Return a hash value for a string.  This uses the hashing
      algorithm used for interning symbols.  It is intended for use by
      the reader in creating interned symbols.
*/
Built_In_Primitive(Prim_String_Hash, 1, "STRING-HASH")
{ Primitive_1_Arg();
  Arg_1_Type(TC_CHARACTER_STRING);
  /* The work is done by Hash, in file FASLOAD.C */
  return Hash(Arg1);
}

/* (STRING_LESS STRING-1 STRING-2)
      [Primitive number 0x59]
      Returns #!TRUE if STRING-1 < STRING-2 using the ASCII character
      code collating sequence.  The test is case-sensitive.
*/
Built_In_Primitive(Prim_String_Less, 2, "STRING-LESS")
{ char *Finger_1, *Finger_2; long Length_1, Length_2, i, Count;
  Primitive_2_Args();
  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_CHARACTER_STRING);
  Length_1 = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  Length_2 = Get_Integer(Fast_Vector_Ref(Arg2, STRING_LENGTH));
  if (Length_1 < Length_2) Count=Length_1;
  else Count=Length_2;
  Finger_1 = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  Finger_2 = (char *) Nth_Vector_Loc(Arg2, STRING_CHARS);
  for (i=0; i<Count; i++, Finger_1++, Finger_2++)
    if (*Finger_1 == *Finger_2) continue;
    else return (*Finger_1 < *Finger_2) ? TRUTH : NIL;
  if (Length_1 < Length_2) return TRUTH;
  else return NIL;
}
\f

    
/* (STRING_POSITION STRING MASK CHARACTER)
      [Primitive number 0x58]
      Scans STRING one character at a time looking for a character
      which is the same as CHARACTER when both are compared after
      masking them with MASK.  If MASK=255 (the usual case) it will
      look for an exact match.  If MASK=255-32=223 then it "ignores"
      the bit which (in ASCII) differentiates upper and lower case
      letters, etc.  Returns the position of the match, or NIL if one
      isn't found.
*/
Built_In_Primitive(Prim_String_Position, 3, "STRING-POSITION")
{ char *Finger; long Length, Character, Mask, i;
  Primitive_3_Args();
  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_FIXNUM);
  Arg_3_Type(TC_FIXNUM);
  Range_Check(Mask, Arg2, 0, MAX_CHAR, ERR_ARG_2_BAD_RANGE);
  Range_Check(Character, Arg3, 0, MAX_CHAR, ERR_ARG_3_BAD_RANGE);
  Length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  Finger= (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  /* The test is made by finding all bits where the character from the
     string and the argument character differ (using XOR, ^).  This is
     then masked and tested to see if the only differences are in
     bits that the mask ignores.
  */
  for (i=0; i<Length; i++)
    if ((Mask & (*Finger++ ^ Character)) == 0) return FIXNUM_0+i;
  return NIL;
}
\f


/* (TRUNCATE_STRING STRING INDEX)
      [Primitive number 0x44]
      A side-effecting string primitive. Lops off the characters in
      STRING from INDEX on, leaving the maximum size (i.e. the GC
      size) of STRING the same.  Returns STRING.
*/
Built_In_Primitive(Prim_Truncate_String, 2, "TRUNCATE-STRING")
{ long Length, Index, i;
  char *To;
  Primitive_2_Args();
  Arg_1_Type(TC_CHARACTER_STRING);
  Arg_2_Type(TC_FIXNUM);
  Length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
  Sign_Extend(Arg2, Index);
  if (Index < 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
  if (Index <= Length) Vector_Ref(Arg1,STRING_LENGTH) = FIXNUM_0+Index;
  /* Now add a null after the last valid positon */
  To = (char *) &Vector_Ref(Arg1, STRING_CHARS);
  for (i=0; i < Index; i++) To++;
  *To = '\0';
  return Arg1;
}
\f


/* (VECTOR_8B? OBJECT)
      [Primitive number 0xA4]
      Returns #!TRUE if OBJECT is an 8-bit vector (a string).
*/
Built_In_Primitive(Prim_Vector_8b, 1, "VECTOR-8B?")
{ Primitive_1_Arg();
  Touch_In_Primitive(Arg1, Arg1);
  return (Type_Code(Arg1) == TC_VECTOR_8B) ? TRUTH : NIL;
}

/* (VECTOR_8B_CONS LENGTH)
      [Primitive number 0xA3]
      Creates an uninitialized 8-bit vector (string) to hold LENGTH
      characters.
*/
Built_In_Primitive(Prim_Vector_8b_Cons, 1, "VECTOR-8B-CONS")
{ long Length;
  Primitive_1_Arg();
  Arg_1_Type(TC_FIXNUM);
  Length = NM_HEADER_LENGTH +
            (sizeof(char)*Get_Integer(Arg1)) /
            sizeof(Pointer) + 1;
  Primitive_GC_If_Needed(Free+Length);
  Free[NM_VECTOR_HEADER] = 
    Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Length-1);
  Free[NM_ENTRY_COUNT] = FIXNUM_0+Get_Integer(Arg1);
  Free += Length;
  return Make_Pointer(TC_VECTOR_8B, Free-Length);
}
\f


/* (VECTOR_8B_REF STRING OFFSET)
      [Primitive number 0xA5]
      Returns the OFFSETth entry (character) in the 8-bit vector
      (string).  Entries are numbered from 0.
*/
Built_In_Primitive(Prim_Vector_8b_Ref, 2, "VECTOR-8B-REF")
{ long Index;
  char *String_Ptr;
  Primitive_2_Args();
  Arg_1_Type(TC_VECTOR_8B);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Index, Arg2,
              0, Get_Integer(Fast_Vector_Ref(Arg1,STRING_LENGTH))-1,
              ERR_ARG_2_BAD_RANGE);
  String_Ptr = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  return Make_Non_Pointer(TC_CHARACTER,
			  (String_Ptr[Index]) & MAX_CHAR);
}

/* (VECTOR_8B_SET STRING OFFSET VALUE)
      [Primitive number 0xA6]
      Stores VALUE (which must be a fixnum between 0 and 255) as the
      OFFSETth entry (character) in the 8-bit vector (string).
      Returns (bad style to rely on this) the previous value of the
      entry.
*/
Built_In_Primitive(Prim_Vec_8b_Set, 3, "VECTOR-8B-SET!")
{ long Index, Value;
  char *String_Ptr;
  Primitive_3_Args();
  Arg_1_Type(TC_VECTOR_8B);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Index, Arg2,
              0, Get_Integer(Fast_Vector_Ref(Arg1,STRING_LENGTH))-1,
              ERR_ARG_2_BAD_RANGE);
  Arg_3_Type(TC_CHARACTER);
  Range_Check(Value, Arg3, 0, MAX_CHAR, ERR_ARG_3_BAD_RANGE);
  String_Ptr = (char *) Nth_Vector_Loc(Arg1, STRING_CHARS);
  Value = Make_Non_Pointer(TC_CHARACTER,
			   (String_Ptr[Index]) & MAX_CHAR);
  String_Ptr[Index] = (char) Get_Integer(Arg3);
  return Value;
}
\f


/* (VECTOR_8B_SIZE STRING)
      [Primitive number 0xAD]
      Returns the number of entries (characters) in the 8-bit vector
      (string).
*/
Built_In_Primitive(Prim_Vec_8b_Size, 1, "VECTOR-8B-SIZE")
{ Primitive_1_Arg();
  Arg_1_Type(TC_VECTOR_8B);
  return Fast_Vector_Ref(Arg1, NM_ENTRY_COUNT);
}
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦cb9138921⟧ TextFile

Derivation

TextFile
