X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/d64d97e537301a9787a569982d67eed8ecdabe8b..18da0d8ad4e5036185acbad3238cbfe2aaf3ca66:/src/data.c

diff --git a/src/data.c b/src/data.c
index 6622088b64..51b0266eca 100644
--- a/src/data.c
+++ b/src/data.c
@@ -76,7 +76,8 @@ static Lisp_Object Qprocess, Qmarker;
 static Lisp_Object Qcompiled_function, Qframe;
 Lisp_Object Qbuffer;
 static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
-static Lisp_Object Qsubrp, Qmany, Qunevalled;
+static Lisp_Object Qsubrp;
+static Lisp_Object Qmany, Qunevalled;
 Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
 static Lisp_Object Qdefun;
 
@@ -85,6 +86,94 @@ static Lisp_Object Qdefalias_fset_function;
 
 static void swap_in_symval_forwarding (struct Lisp_Symbol *, struct Lisp_Buffer_Local_Value *);
 
+static bool
+BOOLFWDP (union Lisp_Fwd *a)
+{
+  return XFWDTYPE (a) == Lisp_Fwd_Bool;
+}
+static bool
+INTFWDP (union Lisp_Fwd *a)
+{
+  return XFWDTYPE (a) == Lisp_Fwd_Int;
+}
+static bool
+KBOARD_OBJFWDP (union Lisp_Fwd *a)
+{
+  return XFWDTYPE (a) == Lisp_Fwd_Kboard_Obj;
+}
+static bool
+OBJFWDP (union Lisp_Fwd *a)
+{
+  return XFWDTYPE (a) == Lisp_Fwd_Obj;
+}
+
+static struct Lisp_Boolfwd *
+XBOOLFWD (union Lisp_Fwd *a)
+{
+  eassert (BOOLFWDP (a));
+  return &a->u_boolfwd;
+}
+static struct Lisp_Kboard_Objfwd *
+XKBOARD_OBJFWD (union Lisp_Fwd *a)
+{
+  eassert (KBOARD_OBJFWDP (a));
+  return &a->u_kboard_objfwd;
+}
+static struct Lisp_Intfwd *
+XINTFWD (union Lisp_Fwd *a)
+{
+  eassert (INTFWDP (a));
+  return &a->u_intfwd;
+}
+static struct Lisp_Objfwd *
+XOBJFWD (union Lisp_Fwd *a)
+{
+  eassert (OBJFWDP (a));
+  return &a->u_objfwd;
+}
+
+static void
+CHECK_SUBR (Lisp_Object x)
+{
+  CHECK_TYPE (SUBRP (x), Qsubrp, x);
+}
+
+static void
+set_blv_found (struct Lisp_Buffer_Local_Value *blv, int found)
+{
+  eassert (found == !EQ (blv->defcell, blv->valcell));
+  blv->found = found;
+}
+
+static Lisp_Object
+blv_value (struct Lisp_Buffer_Local_Value *blv)
+{
+  return XCDR (blv->valcell);
+}
+
+static void
+set_blv_value (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
+{
+  XSETCDR (blv->valcell, val);
+}
+
+static void
+set_blv_where (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
+{
+  blv->where = val;
+}
+
+static void
+set_blv_defcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
+{
+  blv->defcell = val;
+}
+
+static void
+set_blv_valcell (struct Lisp_Buffer_Local_Value *blv, Lisp_Object val)
+{
+  blv->valcell = val;
+}
 
 Lisp_Object
 wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value)
@@ -100,9 +189,9 @@ wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value)
 }
 
 void
-pure_write_error (void)
+pure_write_error (Lisp_Object obj)
 {
-  error ("Attempt to modify read-only object");
+  xsignal2 (Qerror, build_string ("Attempt to modify read-only object"), obj);
 }
 
 void
@@ -288,7 +377,8 @@ DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
 
 DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
        1, 1, 0,
-       doc: /* Return t if OBJECT is a multibyte string.  */)
+       doc: /* Return t if OBJECT is a multibyte string.
+Return nil if OBJECT is either a unibyte string, or not a string.  */)
   (Lisp_Object object)
 {
   if (STRINGP (object) && STRING_MULTIBYTE (object))
@@ -891,19 +981,14 @@ store_symval_forwarding (union Lisp_Fwd *valcontents, register Lisp_Object newva
 			- (char *) &buffer_defaults);
 	  int idx = PER_BUFFER_IDX (offset);
 
-	  Lisp_Object tail;
+	  Lisp_Object tail, buf;
 
 	  if (idx <= 0)
 	    break;
 
-	  for (tail = Vbuffer_alist; CONSP (tail); tail = XCDR (tail))
+	  FOR_EACH_LIVE_BUFFER (tail, buf)
 	    {
-	      Lisp_Object lbuf;
-	      struct buffer *b;
-
-	      lbuf = Fcdr (XCAR (tail));
-	      if (!BUFFERP (lbuf)) continue;
-	      b = XBUFFER (lbuf);
+	      struct buffer *b = XBUFFER (buf);
 
 	      if (! PER_BUFFER_VALUE_P (b, idx))
 		set_per_buffer_value (b, offset, newval);
@@ -1069,40 +1154,6 @@ DEFUN ("set", Fset, Sset, 2, 2, 0,
   return newval;
 }
 
-/* Return true if SYMBOL currently has a let-binding
-   which was made in the buffer that is now current.  */
-
-static bool
-let_shadows_buffer_binding_p (struct Lisp_Symbol *symbol)
-{
-  struct specbinding *p;
-
-  for (p = specpdl_ptr; p > specpdl; )
-    if ((--p)->func == NULL
-	&& CONSP (p->symbol))
-      {
-	struct Lisp_Symbol *let_bound_symbol = XSYMBOL (XCAR (p->symbol));
-	eassert (let_bound_symbol->redirect != SYMBOL_VARALIAS);
-	if (symbol == let_bound_symbol
-	    && XBUFFER (XCDR (XCDR (p->symbol))) == current_buffer)
-	  return 1;
-      }
-
-  return 0;
-}
-
-static bool
-let_shadows_global_binding_p (Lisp_Object symbol)
-{
-  struct specbinding *p;
-
-  for (p = specpdl_ptr; p > specpdl; )
-    if ((--p)->func == NULL && EQ (p->symbol, symbol))
-      return 1;
-
-  return 0;
-}
-
 /* Store the value NEWVAL into SYMBOL.
    If buffer/frame-locality is an issue, WHERE specifies which context to use.
    (nil stands for the current buffer/frame).
@@ -1328,9 +1379,7 @@ for this variable.  The default value is meaningful for variables with
 local bindings in certain buffers.  */)
   (Lisp_Object symbol)
 {
-  register Lisp_Object value;
-
-  value = default_value (symbol);
+  Lisp_Object value = default_value (symbol);
   if (!EQ (value, Qunbound))
     return value;
 
@@ -1422,24 +1471,19 @@ of previous VARs.
 usage: (setq-default [VAR VALUE]...)  */)
   (Lisp_Object args)
 {
-  register Lisp_Object args_left;
-  register Lisp_Object val, symbol;
+  Lisp_Object args_left, symbol, val;
   struct gcpro gcpro1;
 
-  if (NILP (args))
-    return Qnil;
-
-  args_left = args;
+  args_left = val = args;
   GCPRO1 (args);
 
-  do
+  while (CONSP (args_left))
     {
-      val = eval_sub (Fcar (Fcdr (args_left)));
+      val = eval_sub (Fcar (XCDR (args_left)));
       symbol = XCAR (args_left);
       Fset_default (symbol, val);
       args_left = Fcdr (XCDR (args_left));
     }
-  while (!NILP (args_left));
 
   UNGCPRO;
   return val;
@@ -1841,17 +1885,18 @@ BUFFER defaults to the current buffer.  */)
 	XSETBUFFER (tmp, buf);
 	XSETSYMBOL (variable, sym); /* Update in case of aliasing.  */
 
-	for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail))
-	  {
-	    elt = XCAR (tail);
-	    if (EQ (variable, XCAR (elt)))
-	      {
-		eassert (!blv->frame_local);
-		eassert (blv_found (blv) || !EQ (blv->where, tmp));
-		return Qt;
-	      }
-	  }
-	eassert (!blv_found (blv) || !EQ (blv->where, tmp));
+	if (EQ (blv->where, tmp)) /* The binding is already loaded.  */
+	  return blv_found (blv) ? Qt : Qnil;
+	else
+	  for (tail = BVAR (buf, local_var_alist); CONSP (tail); tail = XCDR (tail))
+	    {
+	      elt = XCAR (tail);
+	      if (EQ (variable, XCAR (elt)))
+		{
+		  eassert (!blv->frame_local);
+		  return Qt;
+		}
+	    }
 	return Qnil;
       }
     case SYMBOL_FORWARDED:
@@ -1930,7 +1975,7 @@ If the current binding is global (the default), the value is nil.  */)
       {
 	union Lisp_Fwd *valcontents = SYMBOL_FWD (sym);
 	if (KBOARD_OBJFWDP (valcontents))
-	  return Fframe_terminal (Fselected_frame ());
+	  return Fframe_terminal (selected_frame);
 	else if (!BUFFER_OBJFWDP (valcontents))
 	  return Qnil;
       }
@@ -2210,10 +2255,8 @@ bool-vector.  IDX starts at 0.  */)
 
 /* Arithmetic functions */
 
-enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
-
-static Lisp_Object
-arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
+Lisp_Object
+arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison)
 {
   double f1 = 0, f2 = 0;
   bool floatp = 0;
@@ -2230,32 +2273,32 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
 
   switch (comparison)
     {
-    case equal:
+    case ARITH_EQUAL:
       if (floatp ? f1 == f2 : XINT (num1) == XINT (num2))
 	return Qt;
       return Qnil;
 
-    case notequal:
+    case ARITH_NOTEQUAL:
       if (floatp ? f1 != f2 : XINT (num1) != XINT (num2))
 	return Qt;
       return Qnil;
 
-    case less:
+    case ARITH_LESS:
       if (floatp ? f1 < f2 : XINT (num1) < XINT (num2))
 	return Qt;
       return Qnil;
 
-    case less_or_equal:
+    case ARITH_LESS_OR_EQUAL:
       if (floatp ? f1 <= f2 : XINT (num1) <= XINT (num2))
 	return Qt;
       return Qnil;
 
-    case grtr:
+    case ARITH_GRTR:
       if (floatp ? f1 > f2 : XINT (num1) > XINT (num2))
 	return Qt;
       return Qnil;
 
-    case grtr_or_equal:
+    case ARITH_GRTR_OR_EQUAL:
       if (floatp ? f1 >= f2 : XINT (num1) >= XINT (num2))
 	return Qt;
       return Qnil;
@@ -2265,48 +2308,65 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, enum comparison comparison)
     }
 }
 
-DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
-       doc: /* Return t if two args, both numbers or markers, are equal.  */)
-  (register Lisp_Object num1, Lisp_Object num2)
+static Lisp_Object
+arithcompare_driver (ptrdiff_t nargs, Lisp_Object *args,
+                     enum Arith_Comparison comparison)
+{
+  for (ptrdiff_t argnum = 1; argnum < nargs; ++argnum)
+    {
+      if (EQ (Qnil, arithcompare (args[argnum-1], args[argnum], comparison)))
+        return Qnil;
+    }
+  return Qt;
+}
+
+DEFUN ("=", Feqlsign, Seqlsign, 1, MANY, 0,
+       doc: /* Return t if args, all numbers or markers, are equal.
+usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
 {
-  return arithcompare (num1, num2, equal);
+  return arithcompare_driver (nargs, args, ARITH_EQUAL);
 }
 
-DEFUN ("<", Flss, Slss, 2, 2, 0,
-       doc: /* Return t if first arg is less than second arg.  Both must be numbers or markers.  */)
-  (register Lisp_Object num1, Lisp_Object num2)
+DEFUN ("<", Flss, Slss, 1, MANY, 0,
+       doc: /* Return t if each arg is less than the next arg.  All must be numbers or markers.
+usage: (< NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
 {
-  return arithcompare (num1, num2, less);
+  return arithcompare_driver (nargs, args, ARITH_LESS);
 }
 
-DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
-       doc: /* Return t if first arg is greater than second arg.  Both must be numbers or markers.  */)
-  (register Lisp_Object num1, Lisp_Object num2)
+DEFUN (">", Fgtr, Sgtr, 1, MANY, 0,
+       doc: /* Return t if each arg is greater than the next arg.  All must be numbers or markers.
+usage: (> NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
 {
-  return arithcompare (num1, num2, grtr);
+  return arithcompare_driver (nargs, args, ARITH_GRTR);
 }
 
-DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
-       doc: /* Return t if first arg is less than or equal to second arg.
-Both must be numbers or markers.  */)
-  (register Lisp_Object num1, Lisp_Object num2)
+DEFUN ("<=", Fleq, Sleq, 1, MANY, 0,
+       doc: /* Return t if each arg is less than or equal to the next arg.
+All must be numbers or markers.
+usage: (<= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
 {
-  return arithcompare (num1, num2, less_or_equal);
+  return arithcompare_driver (nargs, args, ARITH_LESS_OR_EQUAL);
 }
 
-DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
-       doc: /* Return t if first arg is greater than or equal to second arg.
-Both must be numbers or markers.  */)
-  (register Lisp_Object num1, Lisp_Object num2)
+DEFUN (">=", Fgeq, Sgeq, 1, MANY, 0,
+       doc: /* Return t if each arg is greater than or equal to the next arg.
+All must be numbers or markers.
+usage: (= NUMBER-OR-MARKER &rest NUMBERS-OR-MARKERS)  */)
+  (ptrdiff_t nargs, Lisp_Object *args)
 {
-  return arithcompare (num1, num2, grtr_or_equal);
+  return arithcompare_driver (nargs, args, ARITH_GRTR_OR_EQUAL);
 }
 
 DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
        doc: /* Return t if first arg is not equal to second arg.  Both must be numbers or markers.  */)
   (register Lisp_Object num1, Lisp_Object num2)
 {
-  return arithcompare (num1, num2, notequal);
+  return arithcompare (num1, num2, ARITH_NOTEQUAL);
 }
 
 DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0,