fns.c

早期freebsd实现

     Lisp_Object fn, seq;
{
  register Lisp_Object tail;
  Lisp_Object dummy;
  register int i;
  struct gcpro gcpro1, gcpro2, gcpro3;

  /* Don't let vals contain any garbage when GC happens.  */
  for (i = 0; i < leni; i++)
    vals[i] = Qnil;

  GCPRO3 (dummy, fn, seq);
  gcpro1.var = vals;
  gcpro1.nvars = leni;
  /* We need not explicitly protect `tail' because it is used only on lists, and
    1) lists are not relocated and 2) the list is marked via `seq' so will not be freed */

  if (XTYPE (seq) == Lisp_Vector)
    {
      for (i = 0; i < leni; i++)
	{
	  dummy = XVECTOR (seq)->contents[i];
	  vals[i] = call1 (fn, dummy);
	}
    }
  else if (XTYPE (seq) == Lisp_String)
    {
      for (i = 0; i < leni; i++)
	{
	  XFASTINT (dummy) = XSTRING (seq)->data[i];
	  vals[i] = call1 (fn, dummy);
	}
    }
  else   /* Must be a list, since Flength did not get an error */
    {
      tail = seq;
      for (i = 0; i < leni; i++)
	{
	  vals[i] = call1 (fn, Fcar (tail));
	  tail = Fcdr (tail);
	}
    }

  UNGCPRO;
}

DEFUN ("mapconcat", Fmapconcat, Smapconcat, 3, 3, 0,
  "Apply FN to each element of SEQ, and concat the results as strings.\n\
In between each pair of results, stick in SEP.\n\
Thus, \" \" as SEP results in spaces between the values return by FN.")
  (fn, seq, sep)
     Lisp_Object fn, seq, sep;
{
  Lisp_Object len;
  register int leni;
  int nargs;
  register Lisp_Object *args;
  register int i;
  int j;
  struct gcpro gcpro1;

  len = Flength (seq);
  leni = XINT (len);
  nargs = leni + leni - 1;
  if (nargs < 0) return build_string ("");

  args = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));

  GCPRO1 (sep);
  mapcar1 (leni, args, fn, seq);
  UNGCPRO;

  /* Broken Xenix/386 compiler can't use a register variable here */
  for (j = leni - 1; j > 0; j--)
    args[j + j] = args[j];

  for (i = 1; i < nargs; i += 2)
    args[i] = sep;

  return Fconcat (nargs, args);
}

DEFUN ("mapcar", Fmapcar, Smapcar, 2, 2, 0,
  "Apply FUNCTION to each element of LIST, and make a list of the results.\n\
The result is a list just as long as LIST.")
  (fn, seq)
     Lisp_Object fn, seq;
{
  register Lisp_Object len;
  register int leni;
  register Lisp_Object *args;

  len = Flength (seq);
  leni = XFASTINT (len);
  args = (Lisp_Object *) alloca (leni * sizeof (Lisp_Object));

  mapcar1 (leni, args, fn, seq);

  return Flist (leni, args);
}

/* Anything that calls this function must protect from GC!  */

DEFUN ("y-or-n-p", Fy_or_n_p, Sy_or_n_p, 1, 1, 0,
  "Ask user a \"y or n\" question.  Return t if answer is \"y\".\n\
No confirmation of the answer is requested; a single character is enough.\n\
Also accepts Space to mean yes, or Delete to mean no.")
  (prompt)
     Lisp_Object prompt;
{
  register int ans;
  Lisp_Object xprompt;
  Lisp_Object args[2];
  int ocech = cursor_in_echo_area;
  struct gcpro gcpro1, gcpro2;

  CHECK_STRING (prompt, 0);
  xprompt = prompt;
  GCPRO2 (prompt, xprompt);

  while (1)
    {
      message ("%s(y or n) ", XSTRING (xprompt)->data);
      cursor_in_echo_area = 1;
      ans = read_command_char (0);
      cursor_in_echo_area = -1;
      message ("%s(y or n) %c", XSTRING (xprompt)->data, ans);
      cursor_in_echo_area = ocech;
      QUIT;
      if (ans >= 0)
	ans = DOWNCASE (ans);
      if (ans == 'y' || ans == ' ')
	{ ans = 'y'; break; }
      if (ans == 'n' || ans == 127)
	break;

      Fding (Qnil);
      Fdiscard_input ();
      if (EQ (xprompt, prompt))
	{
	  args[0] = build_string ("Please answer y or n.  ");
	  args[1] = prompt;
	  xprompt = Fconcat (2, args);
	}
    }
  UNGCPRO;
  return (ans == 'y' ? Qt : Qnil);
}

/* Anything that calls this function must protect from GC!  */

DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, 1, 0,
  "Ask user a yes or no question.  Return t if answer is yes.\n\
The user must confirm the answer with a newline, and can rub it out if not confirmed.")
  (prompt)
     Lisp_Object prompt;
{
  register Lisp_Object ans;
  Lisp_Object args[2];
  struct gcpro gcpro1;

  CHECK_STRING (prompt, 0);

  args[0] = prompt;
  args[1] = build_string ("(yes or no) ");
  prompt = Fconcat (2, args);

  GCPRO1 (prompt);
  while (1)
    {
      ans = Fdowncase (read_minibuf (Vminibuffer_local_map,
				     Qnil, prompt, 0));
      if (XSTRING (ans)->size == 3 && !strcmp (XSTRING (ans)->data, "yes"))
	{
	  UNGCPRO;
	  return Qt;
	}
      if (XSTRING (ans)->size == 2 && !strcmp (XSTRING (ans)->data, "no"))
	{
	  UNGCPRO;
	  return Qnil;
	}

      Fding (Qnil);
      Fdiscard_input ();
      message ("Please answer yes or no.");
      Fsleep_for (make_number (2));
    }
}

#ifndef HAVE_GETLOADAVG
/* Avoid static vars inside a function since in HPUX they dump as pure.  */
static int ldav_initialized;
static int ldav_channel;
#ifdef LOAD_AVE_TYPE
#ifndef VMS
static struct nlist ldav_nl[2];
#endif /* not VMS */
#endif /* LOAD_AVE_TYPE */

#define channel ldav_channel
#define initialized ldav_initialized
#define nl ldav_nl
#endif /* not HAVE_GETLOADAVG */

DEFUN ("load-average", Fload_average, Sload_average, 0, 0, 0,
  "Return the current 1 minute, 5 minute and 15 minute load averages\n\
in a list (all floating point load average values are multiplied by 100\n\
and then turned into integers).")
  ()
{
#ifndef LOAD_AVE_TYPE
  error ("load-average not implemented for this operating system");

#else /* LOAD_AVE_TYPE defined */

  LOAD_AVE_TYPE load_ave[3];
#ifdef VMS
#ifndef eunice
#include <iodef.h>
#include <descrip.h>
#else
#include <vms/iodef.h>
  struct {int dsc$w_length; char *dsc$a_pointer;} descriptor;
#endif /* eunice */
#endif /* VMS */

  /* If this fails for any reason, we can return (0 0 0) */
  load_ave[0] = 0.0; load_ave[1] = 0.0; load_ave[2] = 0.0;

#ifdef VMS
  /*
   *	VMS specific code -- read from the Load Ave driver
   */

  /*
   *	Ensure that there is a channel open to the load ave device
   */
  if (initialized == 0)
    {
      /* Attempt to open the channel */
#ifdef eunice
      descriptor.size = 18;
      descriptor.ptr  = "$$VMS_LOAD_AVERAGE";
#else
      $DESCRIPTOR(descriptor, "LAV0:");
#endif
      if (sys$assign (&descriptor, &channel, 0, 0) & 1)
	initialized = 1;
    }
  /*
   *	Read the load average vector
   */
  if (initialized)
    {
      if (!(sys$qiow (0, channel, IO$_READVBLK, 0, 0, 0,
		     load_ave, 12, 0, 0, 0, 0)
	    & 1))
	{
	  sys$dassgn (channel);
	  initialized = 0;
	}
    }
#else  /* not VMS */
#ifdef HAVE_GETLOADAVG
  (void) getloadavg (load_ave, 3);
#else  /* not HAVE_GETLOADAVG */
  /*
   *	4.2BSD UNIX-specific code -- read _avenrun from /dev/kmem
   */

  /*
   *	Make sure we have the address of _avenrun
   */
  if (nl[0].n_value == 0)
    {
      /*
       *	Get the address of _avenrun
       */
#ifndef NLIST_STRUCT
      strcpy (nl[0].n_name, LDAV_SYMBOL);
      nl[1].n_zeroes = 0;
#else /* NLIST_STRUCT */
#ifdef convex
      nl[0].n_un.n_name = LDAV_SYMBOL;
      nl[1].n_un.n_name = 0;
#else /* not convex */
      nl[0].n_name = LDAV_SYMBOL;
      nl[1].n_name = 0;
#endif /* not convex */
#endif /* NLIST_STRUCT */

#ifdef IRIS_4D
	{
#include <sys/types.h>
#include <sys/sysmp.h>
	    nl[0].n_value = sysmp(MP_KERNADDR, MPKA_AVENRUN);
	    nl[0].n_value &= 0x7fffffff;
	}
#else
      nlist (KERNEL_FILE, nl);
#endif /* IRIS */

#ifdef FIXUP_KERNEL_SYMBOL_ADDR
      if ((nl[0].n_type & N_TYPE) != N_ABS)
	nl[0].n_value = (nlp->n_value >> 2) | 0xc0000000;
#endif /* FIXUP_KERNEL_SYMBOL_ADDR */
    }
  /*
   *	Make sure we have /dev/kmem open
   */
  if (initialized == 0)
    {
      /*
       *	Open /dev/kmem
       */
      channel = open ("/dev/kmem", 0);
      if (channel >= 0) initialized = 1;
    }
  /*
   *	If we can, get the load ave values
   */
  if ((nl[0].n_value != 0) && (initialized != 0))
    {
      /*
       *	Seek to the correct address
       */
      lseek (channel, (long) nl[0].n_value, 0);
      if (read (channel, load_ave, sizeof load_ave)
	  != sizeof(load_ave))
	{
	  close (channel);
	  initialized = 0;
	}
    }
#endif /* not HAVE_GETLOADAVG */
#endif /* not VMS */

  /*
   *	Return the list of load average values
   */
  return Fcons (make_number (LOAD_AVE_CVT (load_ave[0])),
		Fcons (make_number (LOAD_AVE_CVT (load_ave[1])),
		       Fcons (make_number (LOAD_AVE_CVT (load_ave[2])),
			      Qnil)));
#endif /* LOAD_AVE_TYPE */
}

#undef channel
#undef initialized
#undef nl

Lisp_Object Vfeatures;

DEFUN ("featurep", Ffeaturep, Sfeaturep, 1, 1, 0,
  "Returns t if FEATURE is present in this Emacs.\n\
Use this to conditionalize execution of lisp code based on the presence or\n\
absence of emacs or environment extensions.\n\
Use  provide  to declare that a feature is available.\n\
This function looks at the value of the variable  features.")
     (feature)
     Lisp_Object feature;
{
  register Lisp_Object tem;
  CHECK_SYMBOL (feature, 0);
  tem = Fmemq (feature, Vfeatures);
  return (NULL (tem)) ? Qnil : Qt;
}

DEFUN ("provide", Fprovide, Sprovide, 1, 1, 0,
  "Announce that FEATURE is a feature of the current Emacs.")
     (feature)
     Lisp_Object feature;
{
  register Lisp_Object tem;
  CHECK_SYMBOL (feature, 0);
  if (!NULL (Vautoload_queue))
    Vautoload_queue = Fcons (Fcons (Vfeatures, Qnil), Vautoload_queue);
  tem = Fmemq (feature, Vfeatures);
  if (NULL (tem))
    Vfeatures = Fcons (feature, Vfeatures);
  return feature;
}

DEFUN ("require", Frequire, Srequire, 1, 2, 0,
  "If FEATURE is not present in Emacs (ie (featurep FEATURE) is false),\n\
load FILENAME.  FILENAME is optional and defaults to FEATURE.")
     (feature, file_name)
     Lisp_Object feature, file_name;
{
  register Lisp_Object tem;
  CHECK_SYMBOL (feature, 0);
  tem = Fmemq (feature, Vfeatures);
  if (NULL (tem))
    {
      int count = specpdl_ptr - specpdl;

      /* Value saved here is to be restored into Vautoload_queue */
      record_unwind_protect (un_autoload, Vautoload_queue);
      Vautoload_queue = Qt;

      Fload (NULL (file_name) ? Fsymbol_name (feature) : file_name,
	     Qnil, Qt, Qnil);

      tem = Fmemq (feature, Vfeatures);
      if (NULL (tem))
	error ("Required feature %s was not provided",
	       XSYMBOL (feature)->name->data );

      /* Once loading finishes, don't undo it.  */
      Vautoload_queue = Qt;
      unbind_to (count);
    }
  return feature;
}

syms_of_fns ()
{
  Qstring_lessp = intern ("string-lessp");
  staticpro (&Qstring_lessp);

  DEFVAR_LISP ("features", &Vfeatures,
    "A list of symbols which are the features of the executing emacs.\n\
Used by  featurep  and  require, and altered by  provide.");
  Vfeatures = Qnil;

  defsubr (&Sidentity);
  defsubr (&Srandom);
  defsubr (&Slength);
  defsubr (&Sstring_equal);
  defsubr (&Sstring_lessp);
  defsubr (&Sappend);
  defsubr (&Sconcat);
  defsubr (&Svconcat);
  defsubr (&Scopy_sequence);
  defsubr (&Scopy_alist);
  defsubr (&Ssubstring);
  defsubr (&Snthcdr);
  defsubr (&Snth);
  defsubr (&Selt);
  defsubr (&Smemq);
  defsubr (&Sassq);
  defsubr (&Sassoc);
  defsubr (&Srassq);
  defsubr (&Sdelq);
  defsubr (&Snreverse);
  defsubr (&Sreverse);
  defsubr (&Ssort);
  defsubr (&Sget);
  defsubr (&Sput);
  defsubr (&Sequal);
  defsubr (&Sfillarray);
  defsubr (&Snconc);
  defsubr (&Smapcar);
  defsubr (&Smapconcat);
  defsubr (&Sy_or_n_p);
  defsubr (&Syes_or_no_p);
  defsubr (&Sload_average);
  defsubr (&Sfeaturep);
  defsubr (&Srequire);
  defsubr (&Sprovide);
}