data.c 82.3 KB
Newer Older
Jim Blandy's avatar
Jim Blandy committed
1
/* Primitive operations on Lisp data types for GNU Emacs Lisp interpreter.
2
   Copyright (C) 1985,86,88,93,94,95,97,98, 1999 Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
3 4 5 6 7

This file is part of GNU Emacs.

GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
Karl Heuer's avatar
Karl Heuer committed
8
the Free Software Foundation; either version 2, or (at your option)
Jim Blandy's avatar
Jim Blandy committed
9 10 11 12 13 14 15 16 17
any later version.

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING.  If not, write to
18 19
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */
Jim Blandy's avatar
Jim Blandy committed
20 21


22
#include <config.h>
23
#include <signal.h>
24
#include <stdio.h>
Jim Blandy's avatar
Jim Blandy committed
25
#include "lisp.h"
Jim Blandy's avatar
Jim Blandy committed
26
#include "puresize.h"
Karl Heuer's avatar
Karl Heuer committed
27
#include "charset.h"
Jim Blandy's avatar
Jim Blandy committed
28 29 30

#ifndef standalone
#include "buffer.h"
Richard M. Stallman's avatar
Richard M. Stallman committed
31
#include "keyboard.h"
32
#include "frame.h"
Jim Blandy's avatar
Jim Blandy committed
33 34
#endif

Jim Blandy's avatar
Jim Blandy committed
35
#include "syssignal.h"
Jim Blandy's avatar
Jim Blandy committed
36

Jim Blandy's avatar
Jim Blandy committed
37
#ifdef LISP_FLOAT_TYPE
38

39
#ifdef STDC_HEADERS
40
#include <float.h>
41
#endif
42

43 44 45 46 47 48 49 50 51 52
/* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
#ifndef IEEE_FLOATING_POINT
#if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
     && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
#define IEEE_FLOATING_POINT 1
#else
#define IEEE_FLOATING_POINT 0
#endif
#endif

53 54 55 56 57 58 59 60 61 62
/* Work around a problem that happens because math.h on hpux 7
   defines two static variables--which, in Emacs, are not really static,
   because `static' is defined as nothing.  The problem is that they are
   here, in floatfns.c, and in lread.c.
   These macros prevent the name conflict.  */
#if defined (HPUX) && !defined (HPUX8)
#define _MAXLDBL data_c_maxldbl
#define _NMAXLDBL data_c_nmaxldbl
#endif

Jim Blandy's avatar
Jim Blandy committed
63 64 65
#include <math.h>
#endif /* LISP_FLOAT_TYPE */

66 67 68 69
#if !defined (atof)
extern double atof ();
#endif /* !atof */

70 71 72 73
/* Nonzero means it is an error to set a symbol whose name starts with
   colon.  */
int keyword_symbols_constant_flag;

Jim Blandy's avatar
Jim Blandy committed
74 75 76
Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
Jim Blandy's avatar
Jim Blandy committed
77
Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
Jim Blandy's avatar
Jim Blandy committed
78 79
Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
Roland McGrath's avatar
Roland McGrath committed
80
Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
Jim Blandy's avatar
Jim Blandy committed
81
Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
82
Lisp_Object Qtext_read_only;
83
Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
Jim Blandy's avatar
Jim Blandy committed
84 85
Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
Joseph Arceneaux's avatar
Joseph Arceneaux committed
86
Lisp_Object Qbuffer_or_string_p;
Jim Blandy's avatar
Jim Blandy committed
87
Lisp_Object Qboundp, Qfboundp;
88
Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
89

Jim Blandy's avatar
Jim Blandy committed
90
Lisp_Object Qcdr;
91
Lisp_Object Qad_advice_info, Qad_activate_internal;
Jim Blandy's avatar
Jim Blandy committed
92

93 94 95
Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
Lisp_Object Qoverflow_error, Qunderflow_error;

Jim Blandy's avatar
Jim Blandy committed
96
#ifdef LISP_FLOAT_TYPE
97
Lisp_Object Qfloatp;
Jim Blandy's avatar
Jim Blandy committed
98 99 100
Lisp_Object Qnumberp, Qnumber_or_marker_p;
#endif

101
static Lisp_Object Qinteger, Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
Karl Heuer's avatar
Karl Heuer committed
102 103
static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
Lisp_Object Qprocess;
104
static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
Gerd Moellmann's avatar
Gerd Moellmann committed
105
static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
106

Jim Blandy's avatar
Jim Blandy committed
107 108
static Lisp_Object swap_in_symval_forwarding ();

109 110
Lisp_Object set_internal ();

Jim Blandy's avatar
Jim Blandy committed
111 112 113 114 115 116 117 118 119
Lisp_Object
wrong_type_argument (predicate, value)
     register Lisp_Object predicate, value;
{
  register Lisp_Object tem;
  do
    {
      if (!EQ (Vmocklisp_arguments, Qt))
	{
120
	 if (STRINGP (value) &&
Jim Blandy's avatar
Jim Blandy committed
121
	     (EQ (predicate, Qintegerp) || EQ (predicate, Qinteger_or_marker_p)))
122
	   return Fstring_to_number (value, Qnil);
123
	 if (INTEGERP (value) && EQ (predicate, Qstringp))
124
	   return Fnumber_to_string (value);
Jim Blandy's avatar
Jim Blandy committed
125
	}
126 127 128

      /* If VALUE is not even a valid Lisp object, abort here
	 where we can get a backtrace showing where it came from.  */
129
      if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
130 131
	abort ();

Jim Blandy's avatar
Jim Blandy committed
132 133 134
      value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
      tem = call1 (predicate, value);
    }
Jim Blandy's avatar
Jim Blandy committed
135
  while (NILP (tem));
Jim Blandy's avatar
Jim Blandy committed
136 137 138
  return value;
}

Andreas Schwab's avatar
Andreas Schwab committed
139
void
Jim Blandy's avatar
Jim Blandy committed
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
pure_write_error ()
{
  error ("Attempt to modify read-only object");
}

void
args_out_of_range (a1, a2)
     Lisp_Object a1, a2;
{
  while (1)
    Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Qnil)));
}

void
args_out_of_range_3 (a1, a2, a3)
     Lisp_Object a1, a2, a3;
{
  while (1)
    Fsignal (Qargs_out_of_range, Fcons (a1, Fcons (a2, Fcons (a3, Qnil))));
}

/* On some machines, XINT needs a temporary location.
   Here it is, in case it is needed.  */

int sign_extend_temp;

/* On a few machines, XINT can only be done by calling this.  */

int
sign_extend_lisp_int (num)
170
     EMACS_INT num;
Jim Blandy's avatar
Jim Blandy committed
171
{
172 173
  if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
    return num | (((EMACS_INT) (-1)) << VALBITS);
Jim Blandy's avatar
Jim Blandy committed
174
  else
175
    return num & ((((EMACS_INT) 1) << VALBITS) - 1);
Jim Blandy's avatar
Jim Blandy committed
176 177 178 179 180
}

/* Data type predicates */

DEFUN ("eq", Feq, Seq, 2, 2, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
181
  "Return t if the two args are the same Lisp object.")
Jim Blandy's avatar
Jim Blandy committed
182 183 184 185 186 187 188 189
  (obj1, obj2)
     Lisp_Object obj1, obj2;
{
  if (EQ (obj1, obj2))
    return Qt;
  return Qnil;
}

Richard M. Stallman's avatar
Richard M. Stallman committed
190
DEFUN ("null", Fnull, Snull, 1, 1, 0, "Return t if OBJECT is nil.")
191 192
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
193
{
194
  if (NILP (object))
Jim Blandy's avatar
Jim Blandy committed
195 196 197 198
    return Qt;
  return Qnil;
}

199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220
DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
  "Return a symbol representing the type of OBJECT.\n\
The symbol returned names the object's basic type;\n\
for example, (type-of 1) returns `integer'.")
  (object)
     Lisp_Object object;
{
  switch (XGCTYPE (object))
    {
    case Lisp_Int:
      return Qinteger;

    case Lisp_Symbol:
      return Qsymbol;

    case Lisp_String:
      return Qstring;

    case Lisp_Cons:
      return Qcons;

    case Lisp_Misc:
221
      switch (XMISCTYPE (object))
222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244
	{
	case Lisp_Misc_Marker:
	  return Qmarker;
	case Lisp_Misc_Overlay:
	  return Qoverlay;
	case Lisp_Misc_Float:
	  return Qfloat;
	}
      abort ();

    case Lisp_Vectorlike:
      if (GC_WINDOW_CONFIGURATIONP (object))
	return Qwindow_configuration;
      if (GC_PROCESSP (object))
	return Qprocess;
      if (GC_WINDOWP (object))
	return Qwindow;
      if (GC_SUBRP (object))
	return Qsubr;
      if (GC_COMPILEDP (object))
	return Qcompiled_function;
      if (GC_BUFFERP (object))
	return Qbuffer;
245 246 247 248
      if (GC_CHAR_TABLE_P (object))
	return Qchar_table;
      if (GC_BOOL_VECTOR_P (object))
	return Qbool_vector;
249 250
      if (GC_FRAMEP (object))
	return Qframe;
Gerd Moellmann's avatar
Gerd Moellmann committed
251 252
      if (GC_HASH_TABLE_P (object))
	return Qhash_table;
253 254 255 256 257 258 259 260 261 262 263 264
      return Qvector;

#ifdef LISP_FLOAT_TYPE
    case Lisp_Float:
      return Qfloat;
#endif

    default:
      abort ();
    }
}

Richard M. Stallman's avatar
Richard M. Stallman committed
265
DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "Return t if OBJECT is a cons cell.")
266 267
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
268
{
269
  if (CONSP (object))
Jim Blandy's avatar
Jim Blandy committed
270 271 272 273
    return Qt;
  return Qnil;
}

274 275
DEFUN ("atom", Fatom, Satom, 1, 1, 0,
       "Return t if OBJECT is not a cons cell.  This includes nil.")
276 277
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
278
{
279
  if (CONSP (object))
Jim Blandy's avatar
Jim Blandy committed
280 281 282 283
    return Qnil;
  return Qt;
}

284 285
DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
       "Return t if OBJECT is a list.  This includes nil.")
286 287
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
288
{
289
  if (CONSP (object) || NILP (object))
Jim Blandy's avatar
Jim Blandy committed
290 291 292 293
    return Qt;
  return Qnil;
}

294 295
DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
       "Return t if OBJECT is not a list.  Lists include nil.")
296 297
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
298
{
299
  if (CONSP (object) || NILP (object))
Jim Blandy's avatar
Jim Blandy committed
300 301 302 303
    return Qnil;
  return Qt;
}

304 305
DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
       "Return t if OBJECT is a symbol.")
306 307
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
308
{
309
  if (SYMBOLP (object))
Jim Blandy's avatar
Jim Blandy committed
310 311 312 313
    return Qt;
  return Qnil;
}

314 315
DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
       "Return t if OBJECT is a vector.")
316 317
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
318
{
319
  if (VECTORP (object))
Jim Blandy's avatar
Jim Blandy committed
320 321 322 323
    return Qt;
  return Qnil;
}

324 325
DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
       "Return t if OBJECT is a string.")
326 327
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
328
{
329
  if (STRINGP (object))
Jim Blandy's avatar
Jim Blandy committed
330 331 332 333
    return Qt;
  return Qnil;
}

334 335 336 337 338 339 340 341 342 343 344 345
DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
       1, 1, 0, "Return t if OBJECT is a multibyte string.")
  (object)
     Lisp_Object object;
{
  if (STRINGP (object) && STRING_MULTIBYTE (object))
    return Qt;
  return Qnil;
}

DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
       "Return t if OBJECT is a char-table.")
346 347 348 349 350 351 352 353
  (object)
     Lisp_Object object;
{
  if (CHAR_TABLE_P (object))
    return Qt;
  return Qnil;
}

354 355
DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
       Svector_or_char_table_p, 1, 1, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
356
       "Return t if OBJECT is a char-table or vector.")
357 358 359 360 361 362 363 364
  (object)
     Lisp_Object object;
{
  if (VECTORP (object) || CHAR_TABLE_P (object))
    return Qt;
  return Qnil;
}

Richard M. Stallman's avatar
Richard M. Stallman committed
365
DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0, "Return t if OBJECT is a bool-vector.")
366 367 368 369 370 371 372 373
  (object)
     Lisp_Object object;
{
  if (BOOL_VECTOR_P (object))
    return Qt;
  return Qnil;
}

Richard M. Stallman's avatar
Richard M. Stallman committed
374
DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0, "Return t if OBJECT is an array (string or vector).")
375 376
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
377
{
378 379
  if (VECTORP (object) || STRINGP (object)
      || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
Jim Blandy's avatar
Jim Blandy committed
380 381 382 383 384
    return Qt;
  return Qnil;
}

DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
385
  "Return t if OBJECT is a sequence (list or array).")
386 387
  (object)
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
388
{
389 390
  if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object)
      || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
Jim Blandy's avatar
Jim Blandy committed
391 392 393 394
    return Qt;
  return Qnil;
}

Richard M. Stallman's avatar
Richard M. Stallman committed
395
DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0, "Return t if OBJECT is an editor buffer.")
396 397
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
398
{
399
  if (BUFFERP (object))
Jim Blandy's avatar
Jim Blandy committed
400 401 402 403
    return Qt;
  return Qnil;
}

Richard M. Stallman's avatar
Richard M. Stallman committed
404
DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0, "Return t if OBJECT is a marker (editor pointer).")
405 406
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
407
{
408
  if (MARKERP (object))
Jim Blandy's avatar
Jim Blandy committed
409 410 411 412
    return Qt;
  return Qnil;
}

Richard M. Stallman's avatar
Richard M. Stallman committed
413
DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "Return t if OBJECT is a built-in function.")
414 415
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
416
{
417
  if (SUBRP (object))
Jim Blandy's avatar
Jim Blandy committed
418 419 420 421
    return Qt;
  return Qnil;
}

Jim Blandy's avatar
Jim Blandy committed
422
DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
Richard M. Stallman's avatar
Richard M. Stallman committed
423
       1, 1, 0, "Return t if OBJECT is a byte-compiled function object.")
424 425
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
426
{
427
  if (COMPILEDP (object))
Jim Blandy's avatar
Jim Blandy committed
428 429 430 431
    return Qt;
  return Qnil;
}

432
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
433
  "Return t if OBJECT is a character (an integer) or a string.")
434 435
  (object)
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
436
{
437
  if (INTEGERP (object) || STRINGP (object))
Jim Blandy's avatar
Jim Blandy committed
438 439 440 441
    return Qt;
  return Qnil;
}

Richard M. Stallman's avatar
Richard M. Stallman committed
442
DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0, "Return t if OBJECT is an integer.")
443 444
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
445
{
446
  if (INTEGERP (object))
Jim Blandy's avatar
Jim Blandy committed
447 448 449 450
    return Qt;
  return Qnil;
}

451
DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
452
  "Return t if OBJECT is an integer or a marker (editor pointer).")
453 454
  (object)
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
455
{
456
  if (MARKERP (object) || INTEGERP (object))
Jim Blandy's avatar
Jim Blandy committed
457 458 459 460
    return Qt;
  return Qnil;
}

461
DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
462
  "Return t if OBJECT is a nonnegative integer.")
463 464
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
465
{
466
  if (NATNUMP (object))
Jim Blandy's avatar
Jim Blandy committed
467 468 469 470 471
    return Qt;
  return Qnil;
}

DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
472
       "Return t if OBJECT is a number (floating point or integer).")
473 474
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
475
{
476
  if (NUMBERP (object))
Jim Blandy's avatar
Jim Blandy committed
477
    return Qt;
Jim Blandy's avatar
Jim Blandy committed
478 479
  else
    return Qnil;
Jim Blandy's avatar
Jim Blandy committed
480 481 482 483
}

DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
       Snumber_or_marker_p, 1, 1, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
484
       "Return t if OBJECT is a number or a marker.")
485 486
  (object)
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
487
{
488
  if (NUMBERP (object) || MARKERP (object))
Jim Blandy's avatar
Jim Blandy committed
489 490 491
    return Qt;
  return Qnil;
}
492 493 494

#ifdef LISP_FLOAT_TYPE
DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
Richard M. Stallman's avatar
Richard M. Stallman committed
495
       "Return t if OBJECT is a floating point number.")
496 497
  (object)
     Lisp_Object object;
498
{
499
  if (FLOATP (object))
500 501 502
    return Qt;
  return Qnil;
}
Jim Blandy's avatar
Jim Blandy committed
503 504 505 506 507
#endif /* LISP_FLOAT_TYPE */

/* Extract and set components of lists */

DEFUN ("car", Fcar, Scar, 1, 1, 0,
508
  "Return the car of LIST.  If arg is nil, return nil.\n\
Jim Blandy's avatar
Jim Blandy committed
509 510 511 512 513 514
Error if arg is not nil and not a cons cell.  See also `car-safe'.")
  (list)
     register Lisp_Object list;
{
  while (1)
    {
515
      if (CONSP (list))
516
	return XCAR (list);
Jim Blandy's avatar
Jim Blandy committed
517 518 519 520 521 522 523 524 525 526 527 528
      else if (EQ (list, Qnil))
	return Qnil;
      else
	list = wrong_type_argument (Qlistp, list);
    }
}

DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
  "Return the car of OBJECT if it is a cons cell, or else nil.")
  (object)
     Lisp_Object object;
{
529
  if (CONSP (object))
530
    return XCAR (object);
Jim Blandy's avatar
Jim Blandy committed
531 532 533 534 535
  else
    return Qnil;
}

DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
536
  "Return the cdr of LIST.  If arg is nil, return nil.\n\
Jim Blandy's avatar
Jim Blandy committed
537 538 539 540 541 542 543
Error if arg is not nil and not a cons cell.  See also `cdr-safe'.")

  (list)
     register Lisp_Object list;
{
  while (1)
    {
544
      if (CONSP (list))
545
	return XCDR (list);
Jim Blandy's avatar
Jim Blandy committed
546 547 548 549 550 551 552 553
      else if (EQ (list, Qnil))
	return Qnil;
      else
	list = wrong_type_argument (Qlistp, list);
    }
}

DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
554
  "Return the cdr of OBJECT if it is a cons cell, or else nil.")
Jim Blandy's avatar
Jim Blandy committed
555 556 557
  (object)
     Lisp_Object object;
{
558
  if (CONSP (object))
559
    return XCDR (object);
Jim Blandy's avatar
Jim Blandy committed
560 561 562 563 564
  else
    return Qnil;
}

DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
565
  "Set the car of CELL to be NEWCAR.  Returns NEWCAR.")
Jim Blandy's avatar
Jim Blandy committed
566 567 568
  (cell, newcar)
     register Lisp_Object cell, newcar;
{
569
  if (!CONSP (cell))
Jim Blandy's avatar
Jim Blandy committed
570 571 572
    cell = wrong_type_argument (Qconsp, cell);

  CHECK_IMPURE (cell);
573
  XCAR (cell) = newcar;
Jim Blandy's avatar
Jim Blandy committed
574 575 576 577
  return newcar;
}

DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
578
  "Set the cdr of CELL to be NEWCDR.  Returns NEWCDR.")
Jim Blandy's avatar
Jim Blandy committed
579 580 581
  (cell, newcdr)
     register Lisp_Object cell, newcdr;
{
582
  if (!CONSP (cell))
Jim Blandy's avatar
Jim Blandy committed
583 584 585
    cell = wrong_type_argument (Qconsp, cell);

  CHECK_IMPURE (cell);
586
  XCDR (cell) = newcdr;
Jim Blandy's avatar
Jim Blandy committed
587 588 589 590 591
  return newcdr;
}

/* Extract and set components of symbols */

Richard M. Stallman's avatar
Richard M. Stallman committed
592
DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, "Return t if SYMBOL's value is not void.")
593 594
  (symbol)
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
595 596
{
  Lisp_Object valcontents;
597
  CHECK_SYMBOL (symbol, 0);
Jim Blandy's avatar
Jim Blandy committed
598

599
  valcontents = XSYMBOL (symbol)->value;
Jim Blandy's avatar
Jim Blandy committed
600

Karl Heuer's avatar
Karl Heuer committed
601 602
  if (BUFFER_LOCAL_VALUEP (valcontents)
      || SOME_BUFFER_LOCAL_VALUEP (valcontents))
603
    valcontents = swap_in_symval_forwarding (symbol, valcontents);
Jim Blandy's avatar
Jim Blandy committed
604

605
  return (EQ (valcontents, Qunbound) ? Qnil : Qt);
Jim Blandy's avatar
Jim Blandy committed
606 607
}

Richard M. Stallman's avatar
Richard M. Stallman committed
608
DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0, "Return t if SYMBOL's function definition is not void.")
609 610
  (symbol)
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
611
{
612 613
  CHECK_SYMBOL (symbol, 0);
  return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
Jim Blandy's avatar
Jim Blandy committed
614 615 616
}

DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, "Make SYMBOL's value be void.")
617 618
  (symbol)
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
619
{
620
  CHECK_SYMBOL (symbol, 0);
621 622
  if (NILP (symbol) || EQ (symbol, Qt)
      || (XSYMBOL (symbol)->name->data[0] == ':'
623
	  && EQ (XSYMBOL (symbol)->obarray, initial_obarray)
624
	  && keyword_symbols_constant_flag))
625 626 627
    return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
  Fset (symbol, Qunbound);
  return symbol;
Jim Blandy's avatar
Jim Blandy committed
628 629 630
}

DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0, "Make SYMBOL's function definition be void.")
631 632
  (symbol)
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
633
{
634 635 636 637 638
  CHECK_SYMBOL (symbol, 0);
  if (NILP (symbol) || EQ (symbol, Qt))
    return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
  XSYMBOL (symbol)->function = Qunbound;
  return symbol;
Jim Blandy's avatar
Jim Blandy committed
639 640 641 642
}

DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
  "Return SYMBOL's function definition.  Error if that is void.")
Jim Blandy's avatar
Jim Blandy committed
643 644
  (symbol)
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
645
{
Jim Blandy's avatar
Jim Blandy committed
646 647 648 649
  CHECK_SYMBOL (symbol, 0);
  if (EQ (XSYMBOL (symbol)->function, Qunbound))
    return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
  return XSYMBOL (symbol)->function;
Jim Blandy's avatar
Jim Blandy committed
650 651 652
}

DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0, "Return SYMBOL's property list.")
653 654
  (symbol)
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
655
{
656 657
  CHECK_SYMBOL (symbol, 0);
  return XSYMBOL (symbol)->plist;
Jim Blandy's avatar
Jim Blandy committed
658 659 660
}

DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, "Return SYMBOL's name, a string.")
661 662
  (symbol)
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
663 664 665
{
  register Lisp_Object name;

666 667
  CHECK_SYMBOL (symbol, 0);
  XSETSTRING (name, XSYMBOL (symbol)->name);
Jim Blandy's avatar
Jim Blandy committed
668 669 670 671
  return name;
}

DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
672 673 674
  "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.")
  (symbol, definition)
     register Lisp_Object symbol, definition;
675 676 677 678 679 680
{
  CHECK_SYMBOL (symbol, 0);
  if (NILP (symbol) || EQ (symbol, Qt))
    return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
  if (!NILP (Vautoload_queue) && !EQ (XSYMBOL (symbol)->function, Qunbound))
    Vautoload_queue = Fcons (Fcons (symbol, XSYMBOL (symbol)->function),
Jim Blandy's avatar
Jim Blandy committed
681
			     Vautoload_queue);
682
  XSYMBOL (symbol)->function = definition;
683
  /* Handle automatic advice activation */
684
  if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
685
    {
686
      call2 (Qad_activate_internal, symbol, Qnil);
687
      definition = XSYMBOL (symbol)->function;
688
    }
689
  return definition;
Jim Blandy's avatar
Jim Blandy committed
690 691
}

692
DEFUN ("defalias", Fdefalias, Sdefalias, 2, 2, 0,
693
  "Set SYMBOL's function definition to DEFINITION, and return DEFINITION.\n\
694
Associates the function with the current load file, if any.")
695 696
  (symbol, definition)
     register Lisp_Object symbol, definition;
697
{
698
  definition = Ffset (symbol, definition);
699
  LOADHIST_ATTACH (symbol);
700
  return definition;
701 702
}

Jim Blandy's avatar
Jim Blandy committed
703 704
DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
  "Set SYMBOL's property list to NEWVAL, and return NEWVAL.")
705 706
  (symbol, newplist)
     register Lisp_Object symbol, newplist;
Jim Blandy's avatar
Jim Blandy committed
707
{
708 709
  CHECK_SYMBOL (symbol, 0);
  XSYMBOL (symbol)->plist = newplist;
Jim Blandy's avatar
Jim Blandy committed
710 711
  return newplist;
}
Jim Blandy's avatar
Jim Blandy committed
712

Jim Blandy's avatar
Jim Blandy committed
713 714 715 716 717 718 719 720 721 722 723 724 725

/* Getting and setting values of symbols */

/* Given the raw contents of a symbol value cell,
   return the Lisp value of the symbol.
   This does not handle buffer-local variables; use
   swap_in_symval_forwarding for that.  */

Lisp_Object
do_symval_forwarding (valcontents)
     register Lisp_Object valcontents;
{
  register Lisp_Object val;
726 727
  int offset;
  if (MISCP (valcontents))
728
    switch (XMISCTYPE (valcontents))
729 730 731 732
      {
      case Lisp_Misc_Intfwd:
	XSETINT (val, *XINTFWD (valcontents)->intvar);
	return val;
Jim Blandy's avatar
Jim Blandy committed
733

734 735
      case Lisp_Misc_Boolfwd:
	return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
Jim Blandy's avatar
Jim Blandy committed
736

737 738
      case Lisp_Misc_Objfwd:
	return *XOBJFWD (valcontents)->objvar;
Jim Blandy's avatar
Jim Blandy committed
739

740 741 742
      case Lisp_Misc_Buffer_Objfwd:
	offset = XBUFFER_OBJFWD (valcontents)->offset;
	return *(Lisp_Object *)(offset + (char *)current_buffer);
743

744 745 746
      case Lisp_Misc_Kboard_Objfwd:
	offset = XKBOARD_OBJFWD (valcontents)->offset;
	return *(Lisp_Object *)(offset + (char *)current_kboard);
747
      }
Jim Blandy's avatar
Jim Blandy committed
748 749 750
  return valcontents;
}

751 752
/* Store NEWVAL into SYMBOL, where VALCONTENTS is found in the value cell
   of SYMBOL.  If SYMBOL is buffer-local, VALCONTENTS should be the
Jim Blandy's avatar
Jim Blandy committed
753 754 755 756
   buffer-independent contents of the value cell: forwarded just one
   step past the buffer-localness.  */

void
757 758
store_symval_forwarding (symbol, valcontents, newval)
     Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
759 760
     register Lisp_Object valcontents, newval;
{
761
  switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
Jim Blandy's avatar
Jim Blandy committed
762
    {
763
    case Lisp_Misc:
764
      switch (XMISCTYPE (valcontents))
765 766 767 768
	{
	case Lisp_Misc_Intfwd:
	  CHECK_NUMBER (newval, 1);
	  *XINTFWD (valcontents)->intvar = XINT (newval);
769 770
	  if (*XINTFWD (valcontents)->intvar != XINT (newval))
	    error ("Value out of range for variable `%s'",
771
		   XSYMBOL (symbol)->name->data);
772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787
	  break;

	case Lisp_Misc_Boolfwd:
	  *XBOOLFWD (valcontents)->boolvar = NILP (newval) ? 0 : 1;
	  break;

	case Lisp_Misc_Objfwd:
	  *XOBJFWD (valcontents)->objvar = newval;
	  break;

	case Lisp_Misc_Buffer_Objfwd:
	  {
	    int offset = XBUFFER_OBJFWD (valcontents)->offset;
	    Lisp_Object type;

	    type = *(Lisp_Object *)(offset + (char *)&buffer_local_types);
788 789 790
	    if (XINT (type) == -1)
	      error ("Variable %s is read-only", XSYMBOL (symbol)->name->data);

791 792 793 794 795 796
	    if (! NILP (type) && ! NILP (newval)
		&& XTYPE (newval) != XINT (type))
	      buffer_slot_type_mismatch (offset);

	    *(Lisp_Object *)(offset + (char *)current_buffer) = newval;
	  }
797 798
	  break;

799 800 801
	case Lisp_Misc_Kboard_Objfwd:
	  (*(Lisp_Object *)((char *)current_kboard
			    + XKBOARD_OBJFWD (valcontents)->offset))
802 803 804
	    = newval;
	  break;

805 806 807
	default:
	  goto def;
	}
Jim Blandy's avatar
Jim Blandy committed
808 809 810
      break;

    default:
811
    def:
812
      valcontents = XSYMBOL (symbol)->value;
813 814
      if (BUFFER_LOCAL_VALUEP (valcontents)
	  || SOME_BUFFER_LOCAL_VALUEP (valcontents))
815
	XBUFFER_LOCAL_VALUE (valcontents)->realvalue = newval;
Jim Blandy's avatar
Jim Blandy committed
816
      else
817
	XSYMBOL (symbol)->value = newval;
Jim Blandy's avatar
Jim Blandy committed
818 819 820
    }
}

821
/* Set up the buffer-local symbol SYMBOL for validity in the current
Jim Blandy's avatar
Jim Blandy committed
822 823 824 825
   buffer.  VALCONTENTS is the contents of its value cell.
   Return the value forwarded one step past the buffer-local indicator.  */

static Lisp_Object
826 827
swap_in_symval_forwarding (symbol, valcontents)
     Lisp_Object symbol, valcontents;
Jim Blandy's avatar
Jim Blandy committed
828
{
829
  /* valcontents is a pointer to a struct resembling the cons
Jim Blandy's avatar
Jim Blandy committed
830
     (REALVALUE BUFFER CURRENT-ALIST-ELEMENT . DEFAULT-VALUE)).
831

Jim Blandy's avatar
Jim Blandy committed
832
     CURRENT-ALIST-ELEMENT is a pointer to an element of BUFFER's
833 834 835 836 837 838 839 840 841 842 843
     local_var_alist, that being the element whose car is this
     variable.  Or it can be a pointer to the
     (CURRENT-ALIST-ELEMENT . DEFAULT-VALUE), if BUFFER does not have
     an element in its alist for this variable.

     If the current buffer is not BUFFER, we store the current
     REALVALUE value into CURRENT-ALIST-ELEMENT, then find the
     appropriate alist element for the buffer now current and set up
     CURRENT-ALIST-ELEMENT.  Then we set REALVALUE out of that
     element, and store into BUFFER.

Jim Blandy's avatar
Jim Blandy committed
844 845 846
     Note that REALVALUE can be a forwarding pointer. */

  register Lisp_Object tem1;
847
  tem1 = XBUFFER_LOCAL_VALUE (valcontents)->buffer;
Jim Blandy's avatar
Jim Blandy committed
848

849
  if (NILP (tem1) || current_buffer != XBUFFER (tem1)
850
      || !EQ (selected_frame, XBUFFER_LOCAL_VALUE (valcontents)->frame))
Jim Blandy's avatar
Jim Blandy committed
851
    {
852
      tem1 = XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr);
853
      Fsetcdr (tem1,
854
	       do_symval_forwarding (XBUFFER_LOCAL_VALUE (valcontents)->realvalue));
855
      tem1 = assq_no_quit (symbol, current_buffer->local_var_alist);
856 857
      XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 0;
      XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 0;
Jim Blandy's avatar
Jim Blandy committed
858
      if (NILP (tem1))
859 860
	{
	  if (XBUFFER_LOCAL_VALUE (valcontents)->check_frame)
861
	    tem1 = assq_no_quit (symbol, XFRAME (selected_frame)->param_alist);
862 863 864 865 866 867 868 869
	  if (! NILP (tem1))
	    XBUFFER_LOCAL_VALUE (valcontents)->found_for_frame = 1;
	  else
	    tem1 = XBUFFER_LOCAL_VALUE (valcontents)->cdr;
	}
      else
	XBUFFER_LOCAL_VALUE (valcontents)->found_for_buffer = 1;

870
      XCAR (XBUFFER_LOCAL_VALUE (valcontents)->cdr) = tem1;
871
      XSETBUFFER (XBUFFER_LOCAL_VALUE (valcontents)->buffer, current_buffer);
872
      XBUFFER_LOCAL_VALUE (valcontents)->frame = selected_frame;
873 874
      store_symval_forwarding (symbol,
			       XBUFFER_LOCAL_VALUE (valcontents)->realvalue,
875
			       Fcdr (tem1));
Jim Blandy's avatar
Jim Blandy committed
876
    }
877
  return XBUFFER_LOCAL_VALUE (valcontents)->realvalue;
Jim Blandy's avatar
Jim Blandy committed
878 879
}

Jim Blandy's avatar
Jim Blandy committed
880 881
/* Find the value of a symbol, returning Qunbound if it's not bound.
   This is helpful for code which just wants to get a variable's value
Karl Heuer's avatar
Karl Heuer committed
882
   if it has one, without signaling an error.
Jim Blandy's avatar
Jim Blandy committed
883 884
   Note that it must not be possible to quit
   within this function.  Great care is required for this.  */
Jim Blandy's avatar
Jim Blandy committed
885

Jim Blandy's avatar
Jim Blandy committed
886
Lisp_Object
887 888
find_symbol_value (symbol)
     Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
889
{
890
  register Lisp_Object valcontents;
Jim Blandy's avatar
Jim Blandy committed
891
  register Lisp_Object val;
892 893
  CHECK_SYMBOL (symbol, 0);
  valcontents = XSYMBOL (symbol)->value;
Jim Blandy's avatar
Jim Blandy committed
894

Karl Heuer's avatar
Karl Heuer committed
895 896
  if (BUFFER_LOCAL_VALUEP (valcontents)
      || SOME_BUFFER_LOCAL_VALUEP (valcontents))
897
    valcontents = swap_in_symval_forwarding (symbol, valcontents);
Jim Blandy's avatar
Jim Blandy committed
898

899 900
  if (MISCP (valcontents))
    {
901
      switch (XMISCTYPE (valcontents))
902 903 904 905
	{
	case Lisp_Misc_Intfwd:
	  XSETINT (val, *XINTFWD (valcontents)->intvar);
	  return val;
Jim Blandy's avatar
Jim Blandy committed
906

907 908
	case Lisp_Misc_Boolfwd:
	  return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
Jim Blandy's avatar
Jim Blandy committed
909

910 911
	case Lisp_Misc_Objfwd:
	  return *XOBJFWD (valcontents)->objvar;
Jim Blandy's avatar
Jim Blandy committed
912

913 914 915
	case Lisp_Misc_Buffer_Objfwd:
	  return *(Lisp_Object *)(XBUFFER_OBJFWD (valcontents)->offset
				  + (char *)current_buffer);
916

917 918 919
	case Lisp_Misc_Kboard_Objfwd:
	  return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
				  + (char *)current_kboard);
920
	}
Jim Blandy's avatar
Jim Blandy committed
921 922 923 924 925
    }

  return valcontents;
}

Jim Blandy's avatar
Jim Blandy committed
926 927
DEFUN ("symbol-value", Fsymbol_value, Ssymbol_value, 1, 1, 0,
  "Return SYMBOL's value.  Error if that is void.")
928 929
  (symbol)
     Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
930
{
931
  Lisp_Object val;
Jim Blandy's avatar
Jim Blandy committed
932

933
  val = find_symbol_value (symbol);
Jim Blandy's avatar
Jim Blandy committed
934
  if (EQ (val, Qunbound))
935
    return Fsignal (Qvoid_variable, Fcons (symbol, Qnil));
Jim Blandy's avatar
Jim Blandy committed
936 937 938 939
  else
    return val;
}

Jim Blandy's avatar
Jim Blandy committed
940 941
DEFUN ("set", Fset, Sset, 2, 2, 0,
  "Set SYMBOL's value to NEWVAL, and return NEWVAL.")
942 943
  (symbol, newval)
     register Lisp_Object symbol, newval;
944 945 946 947
{
  return set_internal (symbol, newval, 0);
}

948
/* Store the value NEWVAL into SYMBOL.
949 950 951 952 953 954 955 956
   If BINDFLAG is zero, then if this symbol is supposed to become
   local in every buffer where it is set, then we make it local.
   If BINDFLAG is nonzero, we don't do that.  */

Lisp_Object
set_internal (symbol, newval, bindflag)
     register Lisp_Object symbol, newval;
     int bindflag;
Jim Blandy's avatar
Jim Blandy committed
957
{
958
  int voide = EQ (newval, Qunbound);
Jim Blandy's avatar
Jim Blandy committed
959 960 961

  register Lisp_Object valcontents, tem1, current_alist_element;

962
  CHECK_SYMBOL (symbol, 0);
963 964
  if (NILP (symbol) || EQ (symbol, Qt)
      || (XSYMBOL (symbol)->name->data[0] == ':'
965
	  && EQ (XSYMBOL (symbol)->obarray, initial_obarray)
966
	  && keyword_symbols_constant_flag && ! EQ (newval, symbol)))
967 968
    return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
  valcontents = XSYMBOL (symbol)->value;
Jim Blandy's avatar
Jim Blandy committed
969

970
  if (BUFFER_OBJFWDP (valcontents))
Jim Blandy's avatar
Jim Blandy committed
971
    {
972
      register int idx = XBUFFER_OBJFWD (valcontents)->offset;
973 974
      register int mask = XINT (*((Lisp_Object *)
				  (idx + (char *)&buffer_local_flags)));
975
      if (mask > 0 && ! bindflag)
Jim Blandy's avatar
Jim Blandy committed
976 977 978
	current_buffer->local_var_flags |= mask;
    }

979 980
  else if (BUFFER_LOCAL_VALUEP (valcontents)
	   || SOME_BUFFER_LOCAL_VALUEP (valcontents))
Jim Blandy's avatar
Jim Blandy committed
981
    {