lread.c

早期freebsd实现

		i += c - '0';
	      }
	    else
	      {
		UNREAD (c);
		break;
	      }
	  }
	return i;
      }
    default:
      return c;
    }
}

Lisp_Object Vobarray;
Lisp_Object initial_obarray;

Lisp_Object
check_obarray (obarray)
     Lisp_Object obarray;
{
  while (XTYPE (obarray) != Lisp_Vector || XVECTOR (obarray)->size == 0)
    {
      /* If Vobarray is now invalid, force it to be valid.  */
      if (EQ (Vobarray, obarray)) Vobarray = initial_obarray;

      obarray = wrong_type_argument (Qvectorp, obarray);
    }
  return obarray;
}

static int hash_string ();
Lisp_Object oblookup ();

Lisp_Object
intern (str)
     char *str;
{
  Lisp_Object tem;
  int len = strlen (str);
  Lisp_Object obarray = Vobarray;
  if (XTYPE (obarray) != Lisp_Vector || XVECTOR (obarray)->size == 0)
    obarray = check_obarray (obarray);
  tem = oblookup (obarray, str, len);
  if (XTYPE (tem) == Lisp_Symbol)
    return tem;
  return Fintern ((!NULL (Vpurify_flag)
		   ? make_pure_string (str, len)
		   : make_string (str, len)),
		  obarray);
}

DEFUN ("intern", Fintern, Sintern, 1, 2, 0,
  "Return the symbol whose name is STRING.\n\
A second optional argument specifies the obarray to use;\n\
it defaults to the value of  obarray.")
  (str, obarray)
     Lisp_Object str, obarray;
{
  register Lisp_Object tem, sym, *ptr;

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

  CHECK_STRING (str, 0);

  tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
  if (XTYPE (tem) != Lisp_Int)
    return tem;

  if (!NULL (Vpurify_flag))
    str = Fpurecopy (str);
  sym = Fmake_symbol (str);

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

DEFUN ("intern-soft", Fintern_soft, Sintern_soft, 1, 2, 0,
  "Return the symbol whose name is STRING, or nil if none exists yet.\n\
A second optional argument specifies the obarray to use;\n\
it defaults to the value of  obarray.")
  (str, obarray)
     Lisp_Object str, obarray;
{
  register Lisp_Object tem;

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

  CHECK_STRING (str, 0);

  tem = oblookup (obarray, XSTRING (str)->data, XSTRING (str)->size);
  if (XTYPE (tem) != Lisp_Int)
    return tem;
  return Qnil;
}

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

  if (XTYPE (obarray) != Lisp_Vector ||
      (obsize = XVECTOR (obarray)->size) == 0)
    {
      obarray = check_obarray (obarray);
      obsize = XVECTOR (obarray)->size;
    }
  /* Combining next two lines breaks VMS C 2.3.  */
  hash = hash_string (ptr, size);
  hash %= obsize;
  bucket = XVECTOR (obarray)->contents[hash];
  if (XFASTINT (bucket) == 0)
    ;
  else if (XTYPE (bucket) != Lisp_Symbol)
    error ("Bad data in guts of obarray"); /* Like CADR error message */
  else for (tail = bucket; ; XSET (tail, Lisp_Symbol, XSYMBOL (tail)->next))
      {
	if (XSYMBOL (tail)->name->size == size &&
	    !bcmp (XSYMBOL (tail)->name->data, ptr, size))
	  return tail;
	else if (XSYMBOL (tail)->next == 0)
	  break;
      }
  XSET (tem, Lisp_Int, hash);
  return tem;
}

static int
hash_string (ptr, len)
     unsigned char *ptr;
     int len;
{
  register unsigned char *p = ptr;
  register 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;
}

void
map_obarray (obarray, fn, arg)
     Lisp_Object obarray;
     int (*fn) ();
     Lisp_Object arg;
{
  register int i;
  register Lisp_Object tail;
  CHECK_VECTOR (obarray, 1);
  for (i = XVECTOR (obarray)->size - 1; i >= 0; i--)
    {
      tail = XVECTOR (obarray)->contents[i];
      if (XFASTINT (tail) != 0)
	while (1)
	  {
	    (*fn) (tail, arg);
	    if (XSYMBOL (tail)->next == 0)
	      break;
	    XSET (tail, Lisp_Symbol, XSYMBOL (tail)->next);
	  }
    }
}

mapatoms_1 (sym, function)
     Lisp_Object sym, function;
{
  call1 (function, sym);
}

DEFUN ("mapatoms", Fmapatoms, Smapatoms, 1, 2, 0,
  "Call FUNCTION on every symbol in OBARRAY.\n\
OBARRAY defaults to the value of  obarray.")
  (function, obarray)
     Lisp_Object function, obarray;
{
  Lisp_Object tem;

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

  map_obarray (obarray, mapatoms_1, function);
  return Qnil;
}

#define OBARRAY_SIZE 511

void
init_obarray ()
{
  Lisp_Object oblength;
  int hash;
  Lisp_Object *tem;

  XFASTINT (oblength) = OBARRAY_SIZE;

  Qnil = Fmake_symbol (make_pure_string ("nil", 3));
  Vobarray = Fmake_vector (oblength, make_number (0));
  initial_obarray = Vobarray;
  staticpro (&Vobarray);
  staticpro (&initial_obarray);
  /* Intern nil in the obarray */
  /* These locals are to kludge around a pyramid compiler bug. */
  hash = hash_string ("nil", 3);
  /* Separate statement here to avoid VAXC bug. */
  hash %= OBARRAY_SIZE;
  tem = &XVECTOR (Vobarray)->contents[hash];
  *tem = Qnil;

  Qunbound = Fmake_symbol (make_pure_string ("unbound", 7));
  XSYMBOL (Qnil)->function = Qunbound;
  XSYMBOL (Qunbound)->value = Qunbound;
  XSYMBOL (Qunbound)->function = Qunbound;

  Qt = intern ("t");
  XSYMBOL (Qnil)->value = Qnil;
  XSYMBOL (Qnil)->plist = Qnil;
  XSYMBOL (Qt)->value = Qt;

  /* Qt is correct even if CANNOT_DUMP.  loadup.el will set to nil at end.  */
  Vpurify_flag = Qt;

  Qvariable_documentation = intern ("variable-documentation");

  read_buffer_size = 100;
  read_buffer = (char *) malloc (read_buffer_size);
}

void
defsubr (sname)
     struct Lisp_Subr *sname;
{
  Lisp_Object sym;
  sym = intern (sname->symbol_name);
  XSET (XSYMBOL (sym)->function, Lisp_Subr, sname);
}

#ifdef NOTDEF /* use fset in subr.el now */
void
defalias (sname, string)
     struct Lisp_Subr *sname;
     char *string;
{
  Lisp_Object sym;
  sym = intern (string);
  XSET (XSYMBOL (sym)->function, Lisp_Subr, sname);
}
#endif NOTDEF

/* New replacement for DefIntVar; it ignores the doc string argument
   on the assumption that make-docfile will handle that.  */
/* Define an "integer variable"; a symbol whose value is forwarded
 to a C variable of type int.  Sample call: */
  /* DEFVARINT ("indent-tabs-mode", &indent_tabs_mode, "Documentation");  */

void
defvar_int (namestring, address, doc)
     char *namestring;
     int *address;
     char *doc;
{
  Lisp_Object sym;
  sym = intern (namestring);
  XSET (XSYMBOL (sym)->value, Lisp_Intfwd, address);
}

/* Similar but define a variable whose value is T if address contains 1,
 NIL if address contains 0 */

void
defvar_bool (namestring, address, doc)
     char *namestring;
     int *address;
     char *doc;
{
  Lisp_Object sym;
  sym = intern (namestring);
  XSET (XSYMBOL (sym)->value, Lisp_Boolfwd, address);
}

/* Similar but define a variable whose value is the Lisp Object stored at address. */

void
defvar_lisp (namestring, address, doc)
     char *namestring;
     Lisp_Object *address;
     char *doc;
{
  Lisp_Object sym;
  sym = intern (namestring);
  XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address);
  staticpro (address);
}

/* Similar but don't request gc-marking of the C variable.
   Used when that variable will be gc-marked for some other reason,
   since marking the same slot twice can cause trouble with strings.  */

void
defvar_lisp_nopro (namestring, address, doc)
     char *namestring;
     Lisp_Object *address;
     char *doc;
{
  Lisp_Object sym;
  sym = intern (namestring);
  XSET (XSYMBOL (sym)->value, Lisp_Objfwd, address);
}

#ifndef standalone

/* Similar but define a variable whose value is the Lisp Object stored in
 the current buffer.  address is the address of the slot in the buffer that is current now. */

void
defvar_per_buffer (namestring, address, doc)
     char *namestring;
     Lisp_Object *address;
     char *doc;
{
  Lisp_Object sym;
  int offset;
  extern struct buffer buffer_local_symbols;

  sym = intern (namestring);
  offset = (char *)address - (char *)current_buffer;

  XSET (XSYMBOL (sym)->value, Lisp_Buffer_Objfwd,
	(Lisp_Object *) offset);
  *(Lisp_Object *)(offset + (char *)&buffer_local_symbols) = sym;
  if (*(int *)(offset + (char *)&buffer_local_flags) == 0)
    /* Did a DEFVAR_PER_BUFFER without initializing the corresponding
       slot of buffer_local_flags */
    abort ();
}

#endif standalone

init_read ()
{
  char *normal = PATH_LOADSEARCH;
  Lisp_Object normal_path;

  /* Warn if dirs in the *standard* path don't exist.  */
  normal_path = decode_env_path ("", normal);
  for (; !NULL (normal_path); normal_path = XCONS (normal_path)->cdr)
    {
      Lisp_Object dirfile;
      dirfile = Fcar (normal_path);
      if (!NULL (dirfile))
	{
	  dirfile = Fdirectory_file_name (dirfile);
	  if (access (XSTRING (dirfile)->data, 0) < 0)
	    printf ("Warning: lisp library (%s) does not exist.\n",
		    XSTRING (Fcar (normal_path))->data);
	}
    }

  Vvalues = Qnil;

  Vload_path = decode_env_path ("EMACSLOADPATH", normal);
#ifndef CANNOT_DUMP
  if (!NULL (Vpurify_flag))
    Vload_path = Fcons (build_string ("../lisp"), Vload_path);
#endif /* not CANNOT_DUMP */
  load_in_progress = 0;
}

void
syms_of_read ()
{
  defsubr (&Sread);
  defsubr (&Sread_from_string);
  defsubr (&Sintern);
  defsubr (&Sintern_soft);
  defsubr (&Sload);
  defsubr (&Seval_current_buffer);
  defsubr (&Seval_region);
  defsubr (&Sread_char);
  defsubr (&Sget_file_char);
  defsubr (&Smapatoms);

  DEFVAR_LISP ("obarray", &Vobarray,
    "Symbol table for use by  intern  and  read.\n\
It is a vector whose length ought to be prime for best results.\n\
Each element is a list of all interned symbols whose names hash in that bucket.");

  DEFVAR_LISP ("values", &Vvalues,
    "List of values of all expressions which were read, evaluated and printed.\n\
Order is reverse chronological.");

  DEFVAR_LISP ("standard-input", &Vstandard_input,
    "Stream for read to get input from.\n\
See documentation of read for possible values.");
  Vstandard_input = Qt;

  DEFVAR_LISP ("load-path", &Vload_path,
    "*List of directories to search for files to load.\n\
Each element is a string (directory name) or nil (try default directory).\n\
Initialized based on EMACSLOADPATH environment variable, if any,\n\
otherwise to default specified in by file paths.h when emacs was built.");

  DEFVAR_BOOL ("load-in-progress", &load_in_progress,
    "Non-nil iff inside of  load.");

  Qstandard_input = intern ("standard-input");
  staticpro (&Qstandard_input);

  Qread_char = intern ("read-char");
  staticpro (&Qread_char);

  Qget_file_char = intern ("get-file-char");
  staticpro (&Qget_file_char);

  unrch = -1;
}