data.c 91.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,
Glenn Morris's avatar
Glenn Morris committed
3 4
                 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
                 Free Software Foundation, Inc.
Jim Blandy's avatar
Jim Blandy committed
5 6 7 8 9

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


24
#include <config.h>
25
#include <signal.h>
26
#include <stdio.h>
Jim Blandy's avatar
Jim Blandy committed
27
#include "lisp.h"
Jim Blandy's avatar
Jim Blandy committed
28
#include "puresize.h"
29
#include "character.h"
Jim Blandy's avatar
Jim Blandy committed
30
#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
#include "syssignal.h"
34
#include "termhooks.h"  /* For FRAME_KBOARD reference in y-or-n-p. */
Jim Blandy's avatar
Jim Blandy committed
35

36
#ifdef STDC_HEADERS
37
#include <float.h>
38
#endif
39

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

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

62 63 64 65
#if !defined (atof)
extern double atof ();
#endif /* !atof */

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

77
Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
Jim Blandy's avatar
Jim Blandy committed
78 79
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
80
Lisp_Object Qbuffer_or_string_p, Qkeywordp;
Jim Blandy's avatar
Jim Blandy committed
81
Lisp_Object Qboundp, Qfboundp;
82
Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
83

Jim Blandy's avatar
Jim Blandy committed
84
Lisp_Object Qcdr;
85
Lisp_Object Qad_advice_info, Qad_activate_internal;
Jim Blandy's avatar
Jim Blandy committed
86

87 88 89
Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
Lisp_Object Qoverflow_error, Qunderflow_error;

90
Lisp_Object Qfloatp;
Jim Blandy's avatar
Jim Blandy committed
91 92
Lisp_Object Qnumberp, Qnumber_or_marker_p;

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

101
static Lisp_Object swap_in_symval_forwarding P_ ((Lisp_Object, Lisp_Object));
102

103
Lisp_Object Vmost_positive_fixnum, Vmost_negative_fixnum;
104

105 106 107 108 109

void
circular_list_error (list)
     Lisp_Object list;
{
110
  xsignal (Qcircular_list, list);
111 112 113
}


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

123
  xsignal2 (Qwrong_type_argument, predicate, value);
Jim Blandy's avatar
Jim Blandy committed
124 125
}

Andreas Schwab's avatar
Andreas Schwab committed
126
void
Jim Blandy's avatar
Jim Blandy committed
127 128 129 130 131 132 133 134 135
pure_write_error ()
{
  error ("Attempt to modify read-only object");
}

void
args_out_of_range (a1, a2)
     Lisp_Object a1, a2;
{
136
  xsignal2 (Qargs_out_of_range, a1, a2);
Jim Blandy's avatar
Jim Blandy committed
137 138 139 140 141 142
}

void
args_out_of_range_3 (a1, a2, a3)
     Lisp_Object a1, a2, a3;
{
143
  xsignal3 (Qargs_out_of_range, a1, a2, a3);
Jim Blandy's avatar
Jim Blandy committed
144 145 146 147 148 149 150 151 152 153 154
}

/* 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)
155
     EMACS_INT num;
Jim Blandy's avatar
Jim Blandy committed
156
{
157 158
  if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
    return num | (((EMACS_INT) (-1)) << VALBITS);
Jim Blandy's avatar
Jim Blandy committed
159
  else
160
    return num & ((((EMACS_INT) 1) << VALBITS) - 1);
Jim Blandy's avatar
Jim Blandy committed
161 162 163 164 165
}

/* Data type predicates */

DEFUN ("eq", Feq, Seq, 2, 2, 0,
166 167
       doc: /* Return t if the two args are the same Lisp object.  */)
     (obj1, obj2)
Jim Blandy's avatar
Jim Blandy committed
168 169 170 171 172 173 174
     Lisp_Object obj1, obj2;
{
  if (EQ (obj1, obj2))
    return Qt;
  return Qnil;
}

175 176 177
DEFUN ("null", Fnull, Snull, 1, 1, 0,
       doc: /* Return t if OBJECT is nil.  */)
     (object)
178
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
179
{
180
  if (NILP (object))
Jim Blandy's avatar
Jim Blandy committed
181 182 183 184
    return Qt;
  return Qnil;
}

185
DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
186 187 188 189
       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)
190 191
     Lisp_Object object;
{
192
  switch (XTYPE (object))
193 194 195 196 197 198 199 200 201 202 203 204 205 206
    {
    case Lisp_Int:
      return Qinteger;

    case Lisp_Symbol:
      return Qsymbol;

    case Lisp_String:
      return Qstring;

    case Lisp_Cons:
      return Qcons;

    case Lisp_Misc:
207
      switch (XMISCTYPE (object))
208 209 210 211 212 213 214 215 216 217 218
	{
	case Lisp_Misc_Marker:
	  return Qmarker;
	case Lisp_Misc_Overlay:
	  return Qoverlay;
	case Lisp_Misc_Float:
	  return Qfloat;
	}
      abort ();

    case Lisp_Vectorlike:
219
      if (WINDOW_CONFIGURATIONP (object))
220
	return Qwindow_configuration;
221
      if (PROCESSP (object))
222
	return Qprocess;
223
      if (WINDOWP (object))
224
	return Qwindow;
225
      if (SUBRP (object))
226
	return Qsubr;
227
      if (COMPILEDP (object))
228
	return Qcompiled_function;
229
      if (BUFFERP (object))
230
	return Qbuffer;
231
      if (CHAR_TABLE_P (object))
232
	return Qchar_table;
233
      if (BOOL_VECTOR_P (object))
234
	return Qbool_vector;
235
      if (FRAMEP (object))
236
	return Qframe;
237
      if (HASH_TABLE_P (object))
Gerd Moellmann's avatar
Gerd Moellmann committed
238
	return Qhash_table;
239 240 241 242 243 244 245 246 247 248
      return Qvector;

    case Lisp_Float:
      return Qfloat;

    default:
      abort ();
    }
}

249 250 251
DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
       doc: /* Return t if OBJECT is a cons cell.  */)
     (object)
252
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
253
{
254
  if (CONSP (object))
Jim Blandy's avatar
Jim Blandy committed
255 256 257 258
    return Qt;
  return Qnil;
}

259
DEFUN ("atom", Fatom, Satom, 1, 1, 0,
260 261
       doc: /* Return t if OBJECT is not a cons cell.  This includes nil.  */)
     (object)
262
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
263
{
264
  if (CONSP (object))
Jim Blandy's avatar
Jim Blandy committed
265 266 267 268
    return Qnil;
  return Qt;
}

269
DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
Luc Teirlinck's avatar
Luc Teirlinck committed
270 271
       doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
Otherwise, return nil.  */)
272
     (object)
273
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
274
{
275
  if (CONSP (object) || NILP (object))
Jim Blandy's avatar
Jim Blandy committed
276 277 278 279
    return Qt;
  return Qnil;
}

280
DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
281 282
       doc: /* Return t if OBJECT is not a list.  Lists include nil.  */)
     (object)
283
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
284
{
285
  if (CONSP (object) || NILP (object))
Jim Blandy's avatar
Jim Blandy committed
286 287 288 289
    return Qnil;
  return Qt;
}

290
DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
291 292
       doc: /* Return t if OBJECT is a symbol.  */)
     (object)
293
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
294
{
295
  if (SYMBOLP (object))
Jim Blandy's avatar
Jim Blandy committed
296 297 298 299
    return Qt;
  return Qnil;
}

Dave Love's avatar
Dave Love committed
300 301 302
/* Define this in C to avoid unnecessarily consing up the symbol
   name.  */
DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
303 304 305 306
       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
307 308 309
     Lisp_Object object;
{
  if (SYMBOLP (object)
310
      && SREF (SYMBOL_NAME (object), 0) == ':'
311
      && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
Dave Love's avatar
Dave Love committed
312 313 314 315
    return Qt;
  return Qnil;
}

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

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

336
DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
337 338 339
       1, 1, 0,
       doc: /* Return t if OBJECT is a multibyte string.  */)
     (object)
340 341 342 343 344 345 346 347
     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,
348 349
       doc: /* Return t if OBJECT is a char-table.  */)
     (object)
350 351 352 353 354 355 356
     Lisp_Object object;
{
  if (CHAR_TABLE_P (object))
    return Qt;
  return Qnil;
}

357 358
DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
       Svector_or_char_table_p, 1, 1, 0,
359 360
       doc: /* Return t if OBJECT is a char-table or vector.  */)
     (object)
361 362 363 364 365 366 367
     Lisp_Object object;
{
  if (VECTORP (object) || CHAR_TABLE_P (object))
    return Qt;
  return Qnil;
}

368 369 370
DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
       doc: /* Return t if OBJECT is a bool-vector.  */)
     (object)
371 372 373 374 375 376 377
     Lisp_Object object;
{
  if (BOOL_VECTOR_P (object))
    return Qt;
  return Qnil;
}

378 379 380
DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
       doc: /* Return t if OBJECT is an array (string or vector).  */)
     (object)
381
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
382
{
383
  if (ARRAYP (object))
Jim Blandy's avatar
Jim Blandy committed
384 385 386 387 388
    return Qt;
  return Qnil;
}

DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
389 390
       doc: /* Return t if OBJECT is a sequence (list or array).  */)
     (object)
391
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
392
{
393
  if (CONSP (object) || NILP (object) || ARRAYP (object))
Jim Blandy's avatar
Jim Blandy committed
394 395 396 397
    return Qt;
  return Qnil;
}

398 399 400
DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
       doc: /* Return t if OBJECT is an editor buffer.  */)
     (object)
401
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
402
{
403
  if (BUFFERP (object))
Jim Blandy's avatar
Jim Blandy committed
404 405 406 407
    return Qt;
  return Qnil;
}

408 409 410
DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
       doc: /* Return t if OBJECT is a marker (editor pointer).  */)
     (object)
411
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
412
{
413
  if (MARKERP (object))
Jim Blandy's avatar
Jim Blandy committed
414 415 416 417
    return Qt;
  return Qnil;
}

418 419 420
DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
       doc: /* Return t if OBJECT is a built-in function.  */)
     (object)
421
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
422
{
423
  if (SUBRP (object))
Jim Blandy's avatar
Jim Blandy committed
424 425 426 427
    return Qt;
  return Qnil;
}

Jim Blandy's avatar
Jim Blandy committed
428
DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
429 430 431
       1, 1, 0,
       doc: /* Return t if OBJECT is a byte-compiled function object.  */)
     (object)
432
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
433
{
434
  if (COMPILEDP (object))
Jim Blandy's avatar
Jim Blandy committed
435 436 437 438
    return Qt;
  return Qnil;
}

439
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
440
       doc: /* Return t if OBJECT is a character or a string.  */)
441
     (object)
442
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
443
{
444
  if (CHARACTERP (object) || STRINGP (object))
Jim Blandy's avatar
Jim Blandy committed
445 446 447 448
    return Qt;
  return Qnil;
}

449 450 451
DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
       doc: /* Return t if OBJECT is an integer.  */)
     (object)
452
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
453
{
454
  if (INTEGERP (object))
Jim Blandy's avatar
Jim Blandy committed
455 456 457 458
    return Qt;
  return Qnil;
}

459
DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
460 461
       doc: /* Return t if OBJECT is an integer or a marker (editor pointer).  */)
     (object)
462
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
463
{
464
  if (MARKERP (object) || INTEGERP (object))
Jim Blandy's avatar
Jim Blandy committed
465 466 467 468
    return Qt;
  return Qnil;
}

469
DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
470 471
       doc: /* Return t if OBJECT is a nonnegative integer.  */)
     (object)
472
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
473
{
474
  if (NATNUMP (object))
Jim Blandy's avatar
Jim Blandy committed
475 476 477 478 479
    return Qt;
  return Qnil;
}

DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
480 481
       doc: /* Return t if OBJECT is a number (floating point or integer).  */)
     (object)
482
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
483
{
484
  if (NUMBERP (object))
Jim Blandy's avatar
Jim Blandy committed
485
    return Qt;
Jim Blandy's avatar
Jim Blandy committed
486 487
  else
    return Qnil;
Jim Blandy's avatar
Jim Blandy committed
488 489 490 491
}

DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
       Snumber_or_marker_p, 1, 1, 0,
492 493
       doc: /* Return t if OBJECT is a number or a marker.  */)
     (object)
494
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
495
{
496
  if (NUMBERP (object) || MARKERP (object))
Jim Blandy's avatar
Jim Blandy committed
497 498 499
    return Qt;
  return Qnil;
}
500 501

DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
502 503
       doc: /* Return t if OBJECT is a floating point number.  */)
     (object)
504
     Lisp_Object object;
505
{
506
  if (FLOATP (object))
507 508 509
    return Qt;
  return Qnil;
}
510

Jim Blandy's avatar
Jim Blandy committed
511 512 513 514

/* Extract and set components of lists */

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

Luc Teirlinck's avatar
Luc Teirlinck committed
518 519
See Info node `(elisp)Cons Cells' for a discussion of related basic
Lisp concepts such as car, cdr, cons cell and list.  */)
520
     (list)
Jim Blandy's avatar
Jim Blandy committed
521 522
     register Lisp_Object list;
{
523
  return CAR (list);
Jim Blandy's avatar
Jim Blandy committed
524 525 526
}

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

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

Luc Teirlinck's avatar
Luc Teirlinck committed
538 539
See Info node `(elisp)Cons Cells' for a discussion of related basic
Lisp concepts such as cdr, car, cons cell and list.  */)
540
     (list)
Jim Blandy's avatar
Jim Blandy committed
541 542
     register Lisp_Object list;
{
543
  return CDR (list);
Jim Blandy's avatar
Jim Blandy committed
544 545 546
}

DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
547 548
       doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil.  */)
     (object)
Jim Blandy's avatar
Jim Blandy committed
549 550
     Lisp_Object object;
{
551
  return CDR_SAFE (object);
Jim Blandy's avatar
Jim Blandy committed
552 553 554
}

DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
555 556
       doc: /* Set the car of CELL to be NEWCAR.  Returns NEWCAR.  */)
     (cell, newcar)
Jim Blandy's avatar
Jim Blandy committed
557 558
     register Lisp_Object cell, newcar;
{
559
  CHECK_CONS (cell);
Jim Blandy's avatar
Jim Blandy committed
560
  CHECK_IMPURE (cell);
561
  XSETCAR (cell, newcar);
Jim Blandy's avatar
Jim Blandy committed
562 563 564 565
  return newcar;
}

DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
566 567
       doc: /* Set the cdr of CELL to be NEWCDR.  Returns NEWCDR.  */)
     (cell, newcdr)
Jim Blandy's avatar
Jim Blandy committed
568 569
     register Lisp_Object cell, newcdr;
{
570
  CHECK_CONS (cell);
Jim Blandy's avatar
Jim Blandy committed
571
  CHECK_IMPURE (cell);
572
  XSETCDR (cell, newcdr);
Jim Blandy's avatar
Jim Blandy committed
573 574 575 576 577
  return newcdr;
}

/* Extract and set components of symbols */

578 579 580
DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
       doc: /* Return t if SYMBOL's value is not void.  */)
     (symbol)
581
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
582 583
{
  Lisp_Object valcontents;
584
  CHECK_SYMBOL (symbol);
Jim Blandy's avatar
Jim Blandy committed
585

586
  valcontents = SYMBOL_VALUE (symbol);
Jim Blandy's avatar
Jim Blandy committed
587

588
  if (BUFFER_LOCAL_VALUEP (valcontents))
589
    valcontents = swap_in_symval_forwarding (symbol, valcontents);
Jim Blandy's avatar
Jim Blandy committed
590

591
  return (EQ (valcontents, Qunbound) ? Qnil : Qt);
Jim Blandy's avatar
Jim Blandy committed
592 593
}

594 595 596
DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
       doc: /* Return t if SYMBOL's function definition is not void.  */)
     (symbol)
597
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
598
{
599
  CHECK_SYMBOL (symbol);
600
  return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
Jim Blandy's avatar
Jim Blandy committed
601 602
}

603
DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
604 605
       doc: /* Make SYMBOL's value be void.
Return SYMBOL.  */)
606
     (symbol)
607
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
608
{
609
  CHECK_SYMBOL (symbol);
610
  if (SYMBOL_CONSTANT_P (symbol))
611
    xsignal1 (Qsetting_constant, symbol);
612 613
  Fset (symbol, Qunbound);
  return symbol;
Jim Blandy's avatar
Jim Blandy committed
614 615
}

616
DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
617 618
       doc: /* Make SYMBOL's function definition be void.
Return SYMBOL.  */)
619
     (symbol)
620
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
621
{
622
  CHECK_SYMBOL (symbol);
623
  if (NILP (symbol) || EQ (symbol, Qt))
624
    xsignal1 (Qsetting_constant, symbol);
625 626
  XSYMBOL (symbol)->function = Qunbound;
  return symbol;
Jim Blandy's avatar
Jim Blandy committed
627 628 629
}

DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
630 631
       doc: /* Return SYMBOL's function definition.  Error if that is void.  */)
     (symbol)
Jim Blandy's avatar
Jim Blandy committed
632
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
633
{
634
  CHECK_SYMBOL (symbol);
635 636 637
  if (!EQ (XSYMBOL (symbol)->function, Qunbound))
    return XSYMBOL (symbol)->function;
  xsignal1 (Qvoid_function, symbol);
Jim Blandy's avatar
Jim Blandy committed
638 639
}

640 641 642
DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
       doc: /* Return SYMBOL's property list.  */)
     (symbol)
643
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
644
{
645
  CHECK_SYMBOL (symbol);
646
  return XSYMBOL (symbol)->plist;
Jim Blandy's avatar
Jim Blandy committed
647 648
}

649 650 651
DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
       doc: /* Return SYMBOL's name, a string.  */)
     (symbol)
652
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
653 654 655
{
  register Lisp_Object name;

656
  CHECK_SYMBOL (symbol);
657
  name = SYMBOL_NAME (symbol);
Jim Blandy's avatar
Jim Blandy committed
658 659 660 661
  return name;
}

DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
662 663
       doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.  */)
     (symbol, definition)
664
     register Lisp_Object symbol, definition;
665
{
666 667
  register Lisp_Object function;

668
  CHECK_SYMBOL (symbol);
669
  if (NILP (symbol) || EQ (symbol, Qt))
670
    xsignal1 (Qsetting_constant, symbol);
671 672 673 674 675 676 677 678 679

  function = XSYMBOL (symbol)->function;

  if (!NILP (Vautoload_queue) && !EQ (function, Qunbound))
    Vautoload_queue = Fcons (Fcons (symbol, function), Vautoload_queue);

  if (CONSP (function) && EQ (XCAR (function), Qautoload))
    Fput (symbol, Qautoload, XCDR (function));

680
  XSYMBOL (symbol)->function = definition;
681
  /* Handle automatic advice activation */
682
  if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
683
    {
684
      call2 (Qad_activate_internal, symbol, Qnil);
685
      definition = XSYMBOL (symbol)->function;
686
    }
687
  return definition;
Jim Blandy's avatar
Jim Blandy committed
688 689
}

690 691 692
extern Lisp_Object Qfunction_documentation;

DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
693
       doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
Richard M. Stallman's avatar
Richard M. Stallman committed
694 695 696 697
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.  */)
698 699
     (symbol, definition, docstring)
     register Lisp_Object symbol, definition, docstring;
700
{
701
  CHECK_SYMBOL (symbol);
702 703 704
  if (CONSP (XSYMBOL (symbol)->function)
      && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload))
    LOADHIST_ATTACH (Fcons (Qt, symbol));
705
  definition = Ffset (symbol, definition);
706
  LOADHIST_ATTACH (Fcons (Qdefun, symbol));
707 708
  if (!NILP (docstring))
    Fput (symbol, Qfunction_documentation, docstring);
709
  return definition;
710 711
}

Jim Blandy's avatar
Jim Blandy committed
712
DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
Kenichi Handa's avatar
Kenichi Handa committed
713
       doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST.  */)
714
     (symbol, newplist)
715
     register Lisp_Object symbol, newplist;
Jim Blandy's avatar
Jim Blandy committed
716
{
717
  CHECK_SYMBOL (symbol);
718
  XSYMBOL (symbol)->plist = newplist;
Jim Blandy's avatar
Jim Blandy committed
719 720
  return newplist;
}
Jim Blandy's avatar
Jim Blandy committed
721

722
DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
723 724 725 726 727 728
       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)
729 730 731
     Lisp_Object subr;
{
  short minargs, maxargs;
732
  CHECK_SUBR (subr);
733 734 735 736 737 738 739 740 741 742
  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
743 744 745 746 747 748 749
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;
750
  CHECK_SUBR (subr);
Stefan Monnier's avatar
Stefan Monnier committed
751 752 753 754
  name = XSUBR (subr)->symbol_name;
  return make_string (name, strlen (name));
}

Kenichi Handa's avatar
Kenichi Handa committed
755 756
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
757 758
If CMD is not a command, the return value is nil.
Value, if non-nil, is a list \(interactive SPEC).  */)
Kenichi Handa's avatar
Kenichi Handa committed
759 760
     (cmd)
     Lisp_Object cmd;
761
{
762
  Lisp_Object fun = indirect_function (cmd); /* Check cycles.  */
763

764 765 766 767 768 769 770 771 772 773 774 775 776 777
  if (NILP (fun) || EQ (fun, Qunbound))
    return Qnil;

  /* Use an `interactive-form' property if present, analogous to the
     function-documentation property. */
  fun = cmd;
  while (SYMBOLP (fun))
    {
      Lisp_Object tmp = Fget (fun, intern ("interactive-form"));
      if (!NILP (tmp))
	return tmp;
      else
	fun = Fsymbol_function (fun);
    }
Kenichi Handa's avatar
Kenichi Handa committed
778 779 780

  if (SUBRP (fun))
    {
781 782 783 784 785
      char *spec = XSUBR (fun)->intspec;
      if (spec)
	return list2 (Qinteractive,
		      (*spec != '(') ? build_string (spec) :
		      Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
Kenichi Handa's avatar
Kenichi Handa committed
786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805
    }
  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);
	}
    }
806 807 808
  return Qnil;
}

Jim Blandy's avatar
Jim Blandy committed
809

810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830
/***********************************************************************
		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;
831

832 833 834 835
      hare = XSYMBOL (hare)->value;
      tortoise = XSYMBOL (tortoise)->value;

      if (EQ (hare, tortoise))
836
	xsignal1 (Qcyclic_variable_indirection, symbol);
837 838 839 840 841 842 843
    }

  return hare;
}


DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
844 845 846 847 848 849
       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)
850 851 852 853 854 855 856
     Lisp_Object object;
{
  if (SYMBOLP (object))
    object = indirect_variable (object);
  return object;
}

Jim Blandy's avatar
Jim Blandy committed
857 858 859 860 861 862 863 864 865 866 867

/* 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;
868
  if (MISCP (valcontents))
869
    switch (XMISCTYPE (valcontents))
870 871 872 873
      {
      case Lisp_Misc_Intfwd:
	XSETINT (val, *XINTFWD (valcontents)->intvar);
	return val;
Jim Blandy's avatar
Jim Blandy committed
874

875 876
      case Lisp_Misc_Boolfwd:
	return (*XBOOLFWD (valcontents)->boolvar ? Qt : Qnil);
Jim Blandy's avatar
Jim Blandy committed
877

878 879
      case Lisp_Misc_Objfwd:
	return *XOBJFWD (valcontents)->objvar;
Jim Blandy's avatar
Jim Blandy committed
880

881
      case Lisp_Misc_Buffer_Objfwd:
882 883
	return PER_BUFFER_VALUE (current_buffer,
				 XBUFFER_OBJFWD (valcontents)->offset);
884

885
      case Lisp_Misc_Kboard_Objfwd:
886 887 888 889 890 891 892 893 894 895 896
        /* We used to simply use current_kboard here, but from Lisp
           code, it's value is often unexpected.  It seems nicer to
           allow constructions like this to work as intuitively expected:

           	(with-selected-frame frame
                   (define-key local-function-map "\eOP" [f1]))

           On the other hand, this affects the semantics of
           last-command and real-last-command, and people may rely on
           that.  I took a quick look at the Lisp codebase, and I
           don't think anything will break.  --lorentey  */
897 898
	return *(Lisp_Object *)(XKBOARD_OBJFWD (valcontents)->offset
				+ (char *)FRAME_KBOARD (SELECTED_FRAME ()));
899
      }
Jim Blandy's avatar
Jim Blandy committed
900 901 902
  return valcontents;
}

903 904
/* 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
905
   buffer-independent contents of the value cell: forwarded just one
906 907 908 909
   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
910 911

void
912
store_symval_forwarding (symbol, valcontents, newval, buf)
913
     Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
914
     register Lisp_Object valcontents, newval;
915
     struct buffer *buf;
Jim Blandy's avatar
Jim Blandy committed
916
{
917
  switch (SWITCH_ENUM_CAST (XTYPE (valcontents)))
Jim Blandy's avatar
Jim Blandy committed
918
    {
919
    case Lisp_Misc:
920
      switch (XMISCTYPE (valcontents))
921 922
	{
	case Lisp_Misc_Intfwd:
923
	  CHECK_NUMBER (newval);
924
	  *XINTFWD (valcontents)->intvar = XINT (newval);
925 926 927 928 929
	  /* This can never happen since intvar points to an EMACS_INT
	     which is at least large enough to hold a Lisp_Object.
             if (*XINTFWD (valcontents)->intvar != XINT (newval))
	       error ("Value out of range for variable `%s'",
	   	   SDATA (SYMBOL_NAME (symbol))); */
930 931 932
	  break;

	case Lisp_Misc_Boolfwd:
933
	  *XBOOLFWD (valcontents)->boolvar = !NILP (newval);
934 935 936 937
	  break;

	case Lisp_Misc_Objfwd:
	  *XOBJFWD (valcontents)->objvar = newval;
Kenichi Handa's avatar
Kenichi Handa committed
938 939 940 941 942 943 944 945