data.c 95.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, 1986, 1988, 1993, 1994, 1995, 1997, 1998, 1999, 2000,
3
                 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
4 5 6 7 8

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
9
the Free Software Foundation; either version 2, or (at your option)
Jim Blandy's avatar
Jim Blandy committed
10 11 12 13 14 15 16 17 18
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
Lute Kamstra's avatar
Lute Kamstra committed
19 20
the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA.  */
Jim Blandy's avatar
Jim Blandy committed
21 22


23
#include <config.h>
24
#include <signal.h>
25
#include <stdio.h>
Jim Blandy's avatar
Jim Blandy committed
26
#include "lisp.h"
Jim Blandy's avatar
Jim Blandy committed
27
#include "puresize.h"
Karl Heuer's avatar
Karl Heuer committed
28
#include "charset.h"
Jim Blandy's avatar
Jim Blandy committed
29
#include "buffer.h"
Richard M. Stallman's avatar
Richard M. Stallman committed
30
#include "keyboard.h"
31
#include "frame.h"
Jim Blandy's avatar
Jim Blandy committed
32
#include "syssignal.h"
Jim Blandy's avatar
Jim Blandy committed
33

34
#ifdef STDC_HEADERS
35
#include <float.h>
36
#endif
37

38 39 40 41 42 43 44 45 46 47
/* 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

48 49 50 51 52 53 54 55 56 57
/* 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
58 59
#include <math.h>

60 61 62 63
#if !defined (atof)
extern double atof ();
#endif /* !atof */

Jim Blandy's avatar
Jim Blandy committed
64 65 66
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
67
Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
68
Lisp_Object Qcyclic_variable_indirection, Qcircular_list;
Jim Blandy's avatar
Jim Blandy committed
69 70
Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
Roland McGrath's avatar
Roland McGrath committed
71
Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
Jim Blandy's avatar
Jim Blandy committed
72
Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
73
Lisp_Object Qtext_read_only;
Lars Hansen's avatar
Lars Hansen committed
74

75
Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
Jim Blandy's avatar
Jim Blandy committed
76 77
Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
Dave Love's avatar
Dave Love committed
78
Lisp_Object Qbuffer_or_string_p, Qkeywordp;
Jim Blandy's avatar
Jim Blandy committed
79
Lisp_Object Qboundp, Qfboundp;
80
Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
81

Jim Blandy's avatar
Jim Blandy committed
82
Lisp_Object Qcdr;
83
Lisp_Object Qad_advice_info, Qad_activate_internal;
Jim Blandy's avatar
Jim Blandy committed
84

85 86 87
Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
Lisp_Object Qoverflow_error, Qunderflow_error;

88
Lisp_Object Qfloatp;
Jim Blandy's avatar
Jim Blandy committed
89 90
Lisp_Object Qnumberp, Qnumber_or_marker_p;

Lars Hansen's avatar
Lars Hansen committed
91 92
Lisp_Object Qinteger;
static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
Karl Heuer's avatar
Karl Heuer committed
93 94
static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
Lisp_Object Qprocess;
95
static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
Gerd Moellmann's avatar
Gerd Moellmann committed
96
static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
97
static Lisp_Object Qsubrp, Qmany, Qunevalled;
98

99
static Lisp_Object swap_in_symval_forwarding P_ ((Lisp_Object, Lisp_Object));
100

101
Lisp_Object Vmost_positive_fixnum, Vmost_negative_fixnum;
102

103 104 105 106 107 108 109 110 111

void
circular_list_error (list)
     Lisp_Object list;
{
  Fsignal (Qcircular_list, list);
}


Jim Blandy's avatar
Jim Blandy committed
112 113 114 115 116 117 118
Lisp_Object
wrong_type_argument (predicate, value)
     register Lisp_Object predicate, value;
{
  register Lisp_Object tem;
  do
    {
119 120
      /* If VALUE is not even a valid Lisp object, abort here
	 where we can get a backtrace showing where it came from.  */
121
      if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
122 123
	abort ();

Jim Blandy's avatar
Jim Blandy committed
124 125 126
      value = Fsignal (Qwrong_type_argument, Fcons (predicate, Fcons (value, Qnil)));
      tem = call1 (predicate, value);
    }
Jim Blandy's avatar
Jim Blandy committed
127
  while (NILP (tem));
128 129 130 131
  /* This function is marked as NO_RETURN, gcc would warn if it has a
     return statement or if falls off the function.  Other compilers
     warn if no return statement is present.  */
#ifndef __GNUC__
Jim Blandy's avatar
Jim Blandy committed
132
  return value;
133 134 135
#else
  abort ();
#endif
Jim Blandy's avatar
Jim Blandy committed
136 137
}

Andreas Schwab's avatar
Andreas Schwab committed
138
void
Jim Blandy's avatar
Jim Blandy committed
139 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
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)
169
     EMACS_INT num;
Jim Blandy's avatar
Jim Blandy committed
170
{
171 172
  if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
    return num | (((EMACS_INT) (-1)) << VALBITS);
Jim Blandy's avatar
Jim Blandy committed
173
  else
174
    return num & ((((EMACS_INT) 1) << VALBITS) - 1);
Jim Blandy's avatar
Jim Blandy committed
175 176 177 178 179
}

/* Data type predicates */

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

189 190 191
DEFUN ("null", Fnull, Snull, 1, 1, 0,
       doc: /* Return t if OBJECT is nil.  */)
     (object)
192
     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
DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
200 201 202 203
       doc: /* Return a symbol representing the type of OBJECT.
The symbol returned names the object's basic type;
for example, (type-of 1) returns `integer'.  */)
     (object)
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220
     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
      return Qvector;

    case Lisp_Float:
      return Qfloat;

    default:
      abort ();
    }
}

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

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

283
DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
Luc Teirlinck's avatar
Luc Teirlinck committed
284 285
       doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
Otherwise, return nil.  */)
286
     (object)
287
     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
DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
295 296
       doc: /* Return t if OBJECT is not a list.  Lists include nil.  */)
     (object)
297
     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
DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
305 306
       doc: /* Return t if OBJECT is a symbol.  */)
     (object)
307
     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;
}

Dave Love's avatar
Dave Love committed
314 315 316
/* Define this in C to avoid unnecessarily consing up the symbol
   name.  */
DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
317 318 319 320
       doc: /* Return t if OBJECT is a keyword.
This means that it is a symbol with a print name beginning with `:'
interned in the initial obarray.  */)
     (object)
Dave Love's avatar
Dave Love committed
321 322 323
     Lisp_Object object;
{
  if (SYMBOLP (object)
324
      && SREF (SYMBOL_NAME (object), 0) == ':'
325
      && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
Dave Love's avatar
Dave Love committed
326 327 328 329
    return Qt;
  return Qnil;
}

330
DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
331 332
       doc: /* Return t if OBJECT is a vector.  */)
     (object)
333
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
334
{
335
  if (VECTORP (object))
Jim Blandy's avatar
Jim Blandy committed
336 337 338 339
    return Qt;
  return Qnil;
}

340
DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
341 342
       doc: /* Return t if OBJECT is a string.  */)
     (object)
343
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
344
{
345
  if (STRINGP (object))
Jim Blandy's avatar
Jim Blandy committed
346 347 348 349
    return Qt;
  return Qnil;
}

350
DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
351 352 353
       1, 1, 0,
       doc: /* Return t if OBJECT is a multibyte string.  */)
     (object)
354 355 356 357 358 359 360 361
     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,
362 363
       doc: /* Return t if OBJECT is a char-table.  */)
     (object)
364 365 366 367 368 369 370
     Lisp_Object object;
{
  if (CHAR_TABLE_P (object))
    return Qt;
  return Qnil;
}

371 372
DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
       Svector_or_char_table_p, 1, 1, 0,
373 374
       doc: /* Return t if OBJECT is a char-table or vector.  */)
     (object)
375 376 377 378 379 380 381
     Lisp_Object object;
{
  if (VECTORP (object) || CHAR_TABLE_P (object))
    return Qt;
  return Qnil;
}

382 383 384
DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
       doc: /* Return t if OBJECT is a bool-vector.  */)
     (object)
385 386 387 388 389 390 391
     Lisp_Object object;
{
  if (BOOL_VECTOR_P (object))
    return Qt;
  return Qnil;
}

392 393 394
DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
       doc: /* Return t if OBJECT is an array (string or vector).  */)
     (object)
395
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
396
{
397 398
  if (VECTORP (object) || STRINGP (object)
      || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
Jim Blandy's avatar
Jim Blandy committed
399 400 401 402 403
    return Qt;
  return Qnil;
}

DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
404 405
       doc: /* Return t if OBJECT is a sequence (list or array).  */)
     (object)
406
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
407
{
408 409
  if (CONSP (object) || NILP (object) || VECTORP (object) || STRINGP (object)
      || CHAR_TABLE_P (object) || BOOL_VECTOR_P (object))
Jim Blandy's avatar
Jim Blandy committed
410 411 412 413
    return Qt;
  return Qnil;
}

414 415 416
DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
       doc: /* Return t if OBJECT is an editor buffer.  */)
     (object)
417
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
418
{
419
  if (BUFFERP (object))
Jim Blandy's avatar
Jim Blandy committed
420 421 422 423
    return Qt;
  return Qnil;
}

424 425 426
DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
       doc: /* Return t if OBJECT is a marker (editor pointer).  */)
     (object)
427
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
428
{
429
  if (MARKERP (object))
Jim Blandy's avatar
Jim Blandy committed
430 431 432 433
    return Qt;
  return Qnil;
}

434 435 436
DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
       doc: /* Return t if OBJECT is a built-in function.  */)
     (object)
437
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
438
{
439
  if (SUBRP (object))
Jim Blandy's avatar
Jim Blandy committed
440 441 442 443
    return Qt;
  return Qnil;
}

Jim Blandy's avatar
Jim Blandy committed
444
DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
445 446 447
       1, 1, 0,
       doc: /* Return t if OBJECT is a byte-compiled function object.  */)
     (object)
448
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
449
{
450
  if (COMPILEDP (object))
Jim Blandy's avatar
Jim Blandy committed
451 452 453 454
    return Qt;
  return Qnil;
}

455
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
456 457
       doc: /* Return t if OBJECT is a character (an integer) or a string.  */)
     (object)
458
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
459
{
460
  if (INTEGERP (object) || STRINGP (object))
Jim Blandy's avatar
Jim Blandy committed
461 462 463 464
    return Qt;
  return Qnil;
}

465 466 467
DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
       doc: /* Return t if OBJECT is an integer.  */)
     (object)
468
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
469
{
470
  if (INTEGERP (object))
Jim Blandy's avatar
Jim Blandy committed
471 472 473 474
    return Qt;
  return Qnil;
}

475
DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
476 477
       doc: /* Return t if OBJECT is an integer or a marker (editor pointer).  */)
     (object)
478
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
479
{
480
  if (MARKERP (object) || INTEGERP (object))
Jim Blandy's avatar
Jim Blandy committed
481 482 483 484
    return Qt;
  return Qnil;
}

485
DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
486 487
       doc: /* Return t if OBJECT is a nonnegative integer.  */)
     (object)
488
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
489
{
490
  if (NATNUMP (object))
Jim Blandy's avatar
Jim Blandy committed
491 492 493 494 495
    return Qt;
  return Qnil;
}

DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
496 497
       doc: /* Return t if OBJECT is a number (floating point or integer).  */)
     (object)
498
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
499
{
500
  if (NUMBERP (object))
Jim Blandy's avatar
Jim Blandy committed
501
    return Qt;
Jim Blandy's avatar
Jim Blandy committed
502 503
  else
    return Qnil;
Jim Blandy's avatar
Jim Blandy committed
504 505 506 507
}

DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
       Snumber_or_marker_p, 1, 1, 0,
508 509
       doc: /* Return t if OBJECT is a number or a marker.  */)
     (object)
510
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
511
{
512
  if (NUMBERP (object) || MARKERP (object))
Jim Blandy's avatar
Jim Blandy committed
513 514 515
    return Qt;
  return Qnil;
}
516 517

DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
518 519
       doc: /* Return t if OBJECT is a floating point number.  */)
     (object)
520
     Lisp_Object object;
521
{
522
  if (FLOATP (object))
523 524 525
    return Qt;
  return Qnil;
}
526

Jim Blandy's avatar
Jim Blandy committed
527 528 529 530

/* Extract and set components of lists */

DEFUN ("car", Fcar, Scar, 1, 1, 0,
531
       doc: /* Return the car of LIST.  If arg is nil, return nil.
532 533
Error if arg is not nil and not a cons cell.  See also `car-safe'.

Luc Teirlinck's avatar
Luc Teirlinck committed
534 535
See Info node `(elisp)Cons Cells' for a discussion of related basic
Lisp concepts such as car, cdr, cons cell and list.  */)
536
     (list)
Jim Blandy's avatar
Jim Blandy committed
537 538 539 540
     register Lisp_Object list;
{
  while (1)
    {
541
      if (CONSP (list))
542
	return XCAR (list);
Jim Blandy's avatar
Jim Blandy committed
543 544 545 546 547 548 549 550
      else if (EQ (list, Qnil))
	return Qnil;
      else
	list = wrong_type_argument (Qlistp, list);
    }
}

DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
551 552
       doc: /* Return the car of OBJECT if it is a cons cell, or else nil.  */)
     (object)
Jim Blandy's avatar
Jim Blandy committed
553 554
     Lisp_Object object;
{
555
  if (CONSP (object))
556
    return XCAR (object);
Jim Blandy's avatar
Jim Blandy committed
557 558 559 560 561
  else
    return Qnil;
}

DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
562
       doc: /* Return the cdr of LIST.  If arg is nil, return nil.
563 564
Error if arg is not nil and not a cons cell.  See also `cdr-safe'.

Luc Teirlinck's avatar
Luc Teirlinck committed
565 566
See Info node `(elisp)Cons Cells' for a discussion of related basic
Lisp concepts such as cdr, car, cons cell and list.  */)
567
     (list)
Jim Blandy's avatar
Jim Blandy committed
568 569 570 571
     register Lisp_Object list;
{
  while (1)
    {
572
      if (CONSP (list))
573
	return XCDR (list);
Jim Blandy's avatar
Jim Blandy committed
574 575 576 577 578 579 580 581
      else if (EQ (list, Qnil))
	return Qnil;
      else
	list = wrong_type_argument (Qlistp, list);
    }
}

DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
582 583
       doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil.  */)
     (object)
Jim Blandy's avatar
Jim Blandy committed
584 585
     Lisp_Object object;
{
586
  if (CONSP (object))
587
    return XCDR (object);
Jim Blandy's avatar
Jim Blandy committed
588 589 590 591 592
  else
    return Qnil;
}

DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
593 594
       doc: /* Set the car of CELL to be NEWCAR.  Returns NEWCAR.  */)
     (cell, newcar)
Jim Blandy's avatar
Jim Blandy committed
595 596
     register Lisp_Object cell, newcar;
{
597
  if (!CONSP (cell))
Jim Blandy's avatar
Jim Blandy committed
598 599 600
    cell = wrong_type_argument (Qconsp, cell);

  CHECK_IMPURE (cell);
601
  XSETCAR (cell, newcar);
Jim Blandy's avatar
Jim Blandy committed
602 603 604 605
  return newcar;
}

DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
606 607
       doc: /* Set the cdr of CELL to be NEWCDR.  Returns NEWCDR.  */)
     (cell, newcdr)
Jim Blandy's avatar
Jim Blandy committed
608 609
     register Lisp_Object cell, newcdr;
{
610
  if (!CONSP (cell))
Jim Blandy's avatar
Jim Blandy committed
611 612 613
    cell = wrong_type_argument (Qconsp, cell);

  CHECK_IMPURE (cell);
614
  XSETCDR (cell, newcdr);
Jim Blandy's avatar
Jim Blandy committed
615 616 617 618 619
  return newcdr;
}

/* Extract and set components of symbols */

620 621 622
DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
       doc: /* Return t if SYMBOL's value is not void.  */)
     (symbol)
623
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
624 625
{
  Lisp_Object valcontents;
626
  CHECK_SYMBOL (symbol);
Jim Blandy's avatar
Jim Blandy committed
627

628
  valcontents = SYMBOL_VALUE (symbol);
Jim Blandy's avatar
Jim Blandy committed
629

Karl Heuer's avatar
Karl Heuer committed
630 631
  if (BUFFER_LOCAL_VALUEP (valcontents)
      || SOME_BUFFER_LOCAL_VALUEP (valcontents))
632
    valcontents = swap_in_symval_forwarding (symbol, valcontents);
Jim Blandy's avatar
Jim Blandy committed
633

634
  return (EQ (valcontents, Qunbound) ? Qnil : Qt);
Jim Blandy's avatar
Jim Blandy committed
635 636
}

637 638 639
DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
       doc: /* Return t if SYMBOL's function definition is not void.  */)
     (symbol)
640
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
641
{
642
  CHECK_SYMBOL (symbol);
643
  return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
Jim Blandy's avatar
Jim Blandy committed
644 645
}

646
DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
647 648
       doc: /* Make SYMBOL's value be void.
Return SYMBOL.  */)
649
     (symbol)
650
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
651
{
652
  CHECK_SYMBOL (symbol);
653
  if (XSYMBOL (symbol)->constant)
654 655 656
    return Fsignal (Qsetting_constant, Fcons (symbol, Qnil));
  Fset (symbol, Qunbound);
  return symbol;
Jim Blandy's avatar
Jim Blandy committed
657 658
}

659
DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
660 661
       doc: /* Make SYMBOL's function definition be void.
Return SYMBOL.  */)
662
     (symbol)
663
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
664
{
665
  CHECK_SYMBOL (symbol);
666 667 668 669
  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
670 671 672
}

DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
673 674
       doc: /* Return SYMBOL's function definition.  Error if that is void.  */)
     (symbol)
Jim Blandy's avatar
Jim Blandy committed
675
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
676
{
677
  CHECK_SYMBOL (symbol);
Jim Blandy's avatar
Jim Blandy committed
678 679 680
  if (EQ (XSYMBOL (symbol)->function, Qunbound))
    return Fsignal (Qvoid_function, Fcons (symbol, Qnil));
  return XSYMBOL (symbol)->function;
Jim Blandy's avatar
Jim Blandy committed
681 682
}

683 684 685
DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
       doc: /* Return SYMBOL's property list.  */)
     (symbol)
686
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
687
{
688
  CHECK_SYMBOL (symbol);
689
  return XSYMBOL (symbol)->plist;
Jim Blandy's avatar
Jim Blandy committed
690 691
}

692 693 694
DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
       doc: /* Return SYMBOL's name, a string.  */)
     (symbol)
695
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
696 697 698
{
  register Lisp_Object name;

699
  CHECK_SYMBOL (symbol);
700
  name = SYMBOL_NAME (symbol);
Jim Blandy's avatar
Jim Blandy committed
701 702 703 704
  return name;
}

DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
705 706
       doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.  */)
     (symbol, definition)
707
     register Lisp_Object symbol, definition;
708
{
709
  CHECK_SYMBOL (symbol);
710 711 712 713
  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
714
			     Vautoload_queue);
715
  XSYMBOL (symbol)->function = definition;
716
  /* Handle automatic advice activation */
717
  if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
718
    {
719
      call2 (Qad_activate_internal, symbol, Qnil);
720
      definition = XSYMBOL (symbol)->function;
721
    }
722
  return definition;
Jim Blandy's avatar
Jim Blandy committed
723 724
}

725 726 727
extern Lisp_Object Qfunction_documentation;

DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
728
       doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
Richard M. Stallman's avatar
Richard M. Stallman committed
729 730 731 732
Associates the function with the current load file, if any.
The optional third argument DOCSTRING specifies the documentation string
for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string
determined by DEFINITION.  */)
733 734
     (symbol, definition, docstring)
     register Lisp_Object symbol, definition, docstring;
735
{
736
  CHECK_SYMBOL (symbol);
737 738 739
  if (CONSP (XSYMBOL (symbol)->function)
      && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload))
    LOADHIST_ATTACH (Fcons (Qt, symbol));
740
  definition = Ffset (symbol, definition);
741
  LOADHIST_ATTACH (Fcons (Qdefun, symbol));
742 743
  if (!NILP (docstring))
    Fput (symbol, Qfunction_documentation, docstring);
744
  return definition;
745 746
}

Jim Blandy's avatar
Jim Blandy committed
747
DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
Luc Teirlinck's avatar
Luc Teirlinck committed
748
       doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST.  */)
749
     (symbol, newplist)
750
     register Lisp_Object symbol, newplist;
Jim Blandy's avatar
Jim Blandy committed
751
{
752
  CHECK_SYMBOL (symbol);
753
  XSYMBOL (symbol)->plist = newplist;
Jim Blandy's avatar
Jim Blandy committed
754 755
  return newplist;
}
Jim Blandy's avatar
Jim Blandy committed
756

757
DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
758 759 760 761 762 763
       doc: /* Return minimum and maximum number of args allowed for SUBR.
SUBR must be a built-in function.
The returned value is a pair (MIN . MAX).  MIN is the minimum number
of args.  MAX is the maximum number or the symbol `many', for a
function with `&rest' args, or `unevalled' for a special form.  */)
     (subr)
764 765 766 767 768 769 770 771 772 773 774 775 776 777 778
     Lisp_Object subr;
{
  short minargs, maxargs;
  if (!SUBRP (subr))
    wrong_type_argument (Qsubrp, subr);
  minargs = XSUBR (subr)->min_args;
  maxargs = XSUBR (subr)->max_args;
  if (maxargs == MANY)
    return Fcons (make_number (minargs), Qmany);
  else if (maxargs == UNEVALLED)
    return Fcons (make_number (minargs), Qunevalled);
  else
    return Fcons (make_number (minargs), make_number (maxargs));
}

Stefan Monnier's avatar
Stefan Monnier committed
779 780 781 782 783 784 785 786 787 788 789 790 791
DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
       doc: /* Return name of subroutine SUBR.
SUBR must be a built-in function.  */)
     (subr)
     Lisp_Object subr;
{
  const char *name;
  if (!SUBRP (subr))
    wrong_type_argument (Qsubrp, subr);
  name = XSUBR (subr)->symbol_name;
  return make_string (name, strlen (name));
}

792 793
DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
       doc: /* Return the interactive form of CMD or nil if none.
Luc Teirlinck's avatar
Luc Teirlinck committed
794 795
If CMD is not a command, the return value is nil.
Value, if non-nil, is a list \(interactive SPEC).  */)
796 797
     (cmd)
     Lisp_Object cmd;
798
{
799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824
  Lisp_Object fun = indirect_function (cmd);

  if (SUBRP (fun))
    {
      if (XSUBR (fun)->prompt)
	return list2 (Qinteractive, build_string (XSUBR (fun)->prompt));
    }
  else if (COMPILEDP (fun))
    {
      if ((ASIZE (fun) & PSEUDOVECTOR_SIZE_MASK) > COMPILED_INTERACTIVE)
	return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE));
    }
  else if (CONSP (fun))
    {
      Lisp_Object funcar = XCAR (fun);
      if (EQ (funcar, Qlambda))
	return Fassq (Qinteractive, Fcdr (XCDR (fun)));
      else if (EQ (funcar, Qautoload))
	{
	  struct gcpro gcpro1;
	  GCPRO1 (cmd);
	  do_autoload (fun, cmd);
	  UNGCPRO;
	  return Finteractive_form (cmd);
	}
    }
825 826 827
  return Qnil;
}

Jim Blandy's avatar
Jim Blandy committed
828

829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849
/***********************************************************************
		Getting and Setting Values of Symbols
 ***********************************************************************/

/* Return the symbol holding SYMBOL's value.  Signal
   `cyclic-variable-indirection' if SYMBOL's chain of variable
   indirections contains a loop.  */

Lisp_Object
indirect_variable (symbol)
     Lisp_Object symbol;
{
  Lisp_Object tortoise, hare;

  hare = tortoise = symbol;

  while (XSYMBOL (hare)->indirect_variable)
    {
      hare = XSYMBOL (hare)->value;
      if (!XSYMBOL (hare)->indirect_variable)
	break;
850

851 852 853 854 855 856 857 858 859 860 861 862
      hare = XSYMBOL (hare)->value;
      tortoise = XSYMBOL (tortoise)->value;

      if (EQ (hare, tortoise))
	Fsignal (Qcyclic_variable_indirection, Fcons (symbol, Qnil));
    }

  return hare;
}


DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
863 864 865 866 867 868
       doc: /* Return the variable at the end of OBJECT's variable chain.
If OBJECT is a symbol, follow all variable indirections and return the final
variable.  If OBJECT is not a symbol, just return it.
Signal a cyclic-variable-indirection error if there is a loop in the
variable chain of symbols.  */)
     (object)
869 870 871 872 873 874 875
     Lisp_Object object;
{
  if (SYMBOLP (object))
    object = indirect_variable (object);
  return object;
}

Jim Blandy's avatar
Jim Blandy committed
876 877 878 879 880 881 882 883 884 885 886

/* 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;
887 888
  int offset;
  if (MISCP (valcontents))
889
    switch (XMISCTYPE (valcontents))
890 891 892 893
      {
      case Lisp_Misc_Intfwd:
	XSETINT (val, *XINTFWD (valcontents)->intvar);
	return val;
Jim Blandy's avatar
Jim Blandy committed
894

895 896
      case Lisp_Misc_Boolfwd:
	return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
Jim Blandy's avatar
Jim Blandy committed
897

898 899
      case Lisp_Misc_Objfwd:
	return *XOBJFWD (valcontents)->objvar;
Jim Blandy's avatar
Jim Blandy committed
900

901 902
      case Lisp_Misc_Buffer_Objfwd:
	offset = XBUFFER_OBJFWD (valcontents)->offset;
Gerd Moellmann's avatar
Gerd Moellmann committed
903
	return PER_BUFFER_VALUE (current_buffer, offset);
904

905 906 907
      case Lisp_Misc_Kboard_Objfwd:
	offset = XKBOARD_OBJFWD (valcontents)->offset;
	return *(Lisp_Object *)(offset + (char *)current_kboard);
908
      }
Jim Blandy's avatar
Jim Blandy committed
909 910 911
  return valcontents;
}

912 913
/* 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
914
   buffer-independent contents of the value cell: forwarded just one
915 916 917 918
   step past the buffer-localness.

   BUF non-zero means set the value in buffer BUF instead of the
   current buffer.  This only plays a role for per-buffer variables.  */
Jim Blandy's avatar
Jim Blandy committed
919 920

void
921
store_symval_forwarding (symbol, valcontents, newval, buf)
922
     Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
923
     register Lisp_Object valcontents, newval;
924
     struct buffer *buf;