CodeReading: EmacsLisp "defsubr"関数

void
defsubr (sname)
     struct Lisp_Subr *sname;
{
  Lisp_Object sym;
  sym = intern (sname->symbol_name);
  XSETSUBR (XSYMBOL (sym)->function, sname);
}

/* Intern the C string STR: return a symbol with that name,
   interned in the current obarray.  */

Lisp_Object
intern (str)
     const char *str;
{
  Lisp_Object tem;
  int len = strlen (str);
  Lisp_Object obarray;

  obarray = Vobarray;
  if (!VECTORP (obarray) || XVECTOR (obarray)->size == 0)
    obarray = check_obarray (obarray);
  tem = oblookup (obarray, str, len, len);
  if (SYMBOLP (tem))
    return tem;
  return Fintern (make_string (str, len), obarray);
}

/* Return the symbol in OBARRAY whose names matches the string
   of SIZE characters (SIZE_BYTE bytes) at PTR.
   If there is no such symbol in OBARRAY, return nil.

   Also store the bucket number in oblookup_last_bucket_number.  */

Lisp_Object
oblookup (obarray, ptr, size, size_byte)
     Lisp_Object obarray;
     register const char *ptr;
     int size, size_byte;
{
  int hash;
  int obsize;
  register Lisp_Object tail;
  Lisp_Object bucket, tem;

  if (!VECTORP (obarray)
      || (obsize = XVECTOR (obarray)->size) == 0)
    {
      obarray = check_obarray (obarray);
      obsize = XVECTOR (obarray)->size;
    }
  /* This is sometimes needed in the middle of GC.  */
  obsize &= ~ARRAY_MARK_FLAG;
  /* Combining next two lines breaks VMS C 2.3.  */
  hash = hash_string (ptr, size_byte);
  hash %= obsize;
  bucket = XVECTOR (obarray)->contents[hash];
  oblookup_last_bucket_number = hash;
  if (EQ (bucket, make_number (0)))
    ;
  else if (!SYMBOLP (bucket))
    error ("Bad data in guts of obarray"); /* Like CADR error message */
  else
    for (tail = bucket; ; XSETSYMBOL (tail, XSYMBOL (tail)->next))
      {
	if (SBYTES (SYMBOL_NAME (tail)) == size_byte
	    && SCHARS (SYMBOL_NAME (tail)) == size
	    && !bcmp (SDATA (SYMBOL_NAME (tail)), ptr, size_byte))
	  return tail;
	else if (XSYMBOL (tail)->next == 0)
	  break;
      }
  XSETINT (tem, hash);
  return tem;
}

/* In the size word of a vector, this bit means the vector has been marked.  */

#ifndef ARRAY_MARK_FLAG
#define ARRAY_MARK_FLAG ((EMACS_INT) ((EMACS_UINT) 1 << (VALBITS + GCTYPEBITS - 1)))
#endif /* no ARRAY_MARK_FLAG */

static int
hash_string (ptr, len)
     const unsigned char *ptr;
     int len;
{
  register const unsigned char *p = ptr;
  register const unsigned char *end = p + len;
  register unsigned char c;
  register int hash = 0;

  while (p != end)
    {
      c = *p++;
      if (c >= 0140) c -= 40;
      hash = ((hash<<3) + (hash>>28) + c);
    }
  return hash & 07777777777;
}

DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
       doc: /* Return the canonical symbol whose name is STRING.
If there is none, one is created by this function and returned.
A second optional argument specifies the obarray to use;
it defaults to the value of `obarray'.  */)
     (string, obarray)
     Lisp_Object string, obarray;
{
  register Lisp_Object tem, sym, *ptr;

  if (NILP (obarray)) obarray = Vobarray;
  obarray = check_obarray (obarray);

  CHECK_STRING (string);

  tem = oblookup (obarray, SDATA (string),
		  SCHARS (string),
		  SBYTES (string));
  if (!INTEGERP (tem))
    return tem;

  if (!NILP (Vpurify_flag))
    string = Fpurecopy (string);
  sym = Fmake_symbol (string);

  if (EQ (obarray, initial_obarray))
    XSYMBOL (sym)->interned = SYMBOL_INTERNED_IN_INITIAL_OBARRAY;
  else
    XSYMBOL (sym)->interned = SYMBOL_INTERNED;

  if ((SREF (string, 0) == ':')
      && EQ (obarray, initial_obarray))
    {
      XSYMBOL (sym)->constant = 1;
      XSYMBOL (sym)->value = sym;
    }

  ptr = &XVECTOR (obarray)->contents[XINT (tem)];
  if (SYMBOLP (*ptr))
    XSYMBOL (sym)->next = XSYMBOL (*ptr);
  else
    XSYMBOL (sym)->next = 0;
  *ptr = sym;
  return sym;
}