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

This file is part of GNU Emacs.

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

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
19
along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
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"
27
#include "character.h"
Jim Blandy's avatar
Jim Blandy committed
28
#include "buffer.h"
Richard M. Stallman's avatar
Richard M. Stallman committed
29
#include "keyboard.h"
30
#include "frame.h"
Jim Blandy's avatar
Jim Blandy committed
31
#include "syssignal.h"
32
#include "termhooks.h"  /* For FRAME_KBOARD reference in y-or-n-p. */
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

Jim Blandy's avatar
Jim Blandy committed
48 49
#include <math.h>

50 51 52 53
#if !defined (atof)
extern double atof ();
#endif /* !atof */

Jim Blandy's avatar
Jim Blandy committed
54 55 56
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
57
Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
58
Lisp_Object Qcyclic_variable_indirection, Qcircular_list;
Jim Blandy's avatar
Jim Blandy committed
59 60
Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
Roland McGrath's avatar
Roland McGrath committed
61
Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
Jim Blandy's avatar
Jim Blandy committed
62
Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
63
Lisp_Object Qtext_read_only;
Kenichi Handa's avatar
Kenichi Handa committed
64

65
Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
Jim Blandy's avatar
Jim Blandy committed
66 67
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
68
Lisp_Object Qbuffer_or_string_p, Qkeywordp;
Jim Blandy's avatar
Jim Blandy committed
69
Lisp_Object Qboundp, Qfboundp;
70
Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
71

Jim Blandy's avatar
Jim Blandy committed
72
Lisp_Object Qcdr;
73
Lisp_Object Qad_advice_info, Qad_activate_internal;
Jim Blandy's avatar
Jim Blandy committed
74

75 76 77
Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
Lisp_Object Qoverflow_error, Qunderflow_error;

78
Lisp_Object Qfloatp;
Jim Blandy's avatar
Jim Blandy committed
79 80
Lisp_Object Qnumberp, Qnumber_or_marker_p;

Kenichi Handa's avatar
Kenichi Handa committed
81 82
Lisp_Object Qinteger;
static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
Karl Heuer's avatar
Karl Heuer committed
83 84
static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
Lisp_Object Qprocess;
85
static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
Gerd Moellmann's avatar
Gerd Moellmann committed
86
static Lisp_Object Qchar_table, Qbool_vector, Qhash_table;
87
static Lisp_Object Qsubrp, Qmany, Qunevalled;
88

89
static Lisp_Object swap_in_symval_forwarding P_ ((Lisp_Object, Lisp_Object));
90

91
Lisp_Object Vmost_positive_fixnum, Vmost_negative_fixnum;
92

93 94 95 96 97

void
circular_list_error (list)
     Lisp_Object list;
{
98
  xsignal (Qcircular_list, list);
99 100 101
}


Jim Blandy's avatar
Jim Blandy committed
102 103 104 105
Lisp_Object
wrong_type_argument (predicate, value)
     register Lisp_Object predicate, value;
{
106 107
  /* If VALUE is not even a valid Lisp object, abort here
     where we can get a backtrace showing where it came from.  */
108
  if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit)
109
    abort ();
110

111
  xsignal2 (Qwrong_type_argument, predicate, value);
Jim Blandy's avatar
Jim Blandy committed
112 113
}

Andreas Schwab's avatar
Andreas Schwab committed
114
void
Jim Blandy's avatar
Jim Blandy committed
115 116 117 118 119 120 121 122 123
pure_write_error ()
{
  error ("Attempt to modify read-only object");
}

void
args_out_of_range (a1, a2)
     Lisp_Object a1, a2;
{
124
  xsignal2 (Qargs_out_of_range, a1, a2);
Jim Blandy's avatar
Jim Blandy committed
125 126 127 128 129 130
}

void
args_out_of_range_3 (a1, a2, a3)
     Lisp_Object a1, a2, a3;
{
131
  xsignal3 (Qargs_out_of_range, a1, a2, a3);
Jim Blandy's avatar
Jim Blandy committed
132 133 134 135 136 137 138 139 140 141 142
}

/* 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)
143
     EMACS_INT num;
Jim Blandy's avatar
Jim Blandy committed
144
{
145 146
  if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
    return num | (((EMACS_INT) (-1)) << VALBITS);
Jim Blandy's avatar
Jim Blandy committed
147
  else
148
    return num & ((((EMACS_INT) 1) << VALBITS) - 1);
Jim Blandy's avatar
Jim Blandy committed
149 150 151 152 153
}

/* Data type predicates */

DEFUN ("eq", Feq, Seq, 2, 2, 0,
154 155
       doc: /* Return t if the two args are the same Lisp object.  */)
     (obj1, obj2)
Jim Blandy's avatar
Jim Blandy committed
156 157 158 159 160 161 162
     Lisp_Object obj1, obj2;
{
  if (EQ (obj1, obj2))
    return Qt;
  return Qnil;
}

163 164 165
DEFUN ("null", Fnull, Snull, 1, 1, 0,
       doc: /* Return t if OBJECT is nil.  */)
     (object)
166
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
167
{
168
  if (NILP (object))
Jim Blandy's avatar
Jim Blandy committed
169 170 171 172
    return Qt;
  return Qnil;
}

173
DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
174 175 176 177
       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)
178 179
     Lisp_Object object;
{
180
  switch (XTYPE (object))
181 182 183 184 185 186 187 188 189 190 191 192 193 194
    {
    case Lisp_Int:
      return Qinteger;

    case Lisp_Symbol:
      return Qsymbol;

    case Lisp_String:
      return Qstring;

    case Lisp_Cons:
      return Qcons;

    case Lisp_Misc:
195
      switch (XMISCTYPE (object))
196 197 198 199 200 201 202 203 204 205 206
	{
	case Lisp_Misc_Marker:
	  return Qmarker;
	case Lisp_Misc_Overlay:
	  return Qoverlay;
	case Lisp_Misc_Float:
	  return Qfloat;
	}
      abort ();

    case Lisp_Vectorlike:
207
      if (WINDOW_CONFIGURATIONP (object))
208
	return Qwindow_configuration;
209
      if (PROCESSP (object))
210
	return Qprocess;
211
      if (WINDOWP (object))
212
	return Qwindow;
213
      if (SUBRP (object))
214
	return Qsubr;
215
      if (COMPILEDP (object))
216
	return Qcompiled_function;
217
      if (BUFFERP (object))
218
	return Qbuffer;
219
      if (CHAR_TABLE_P (object))
220
	return Qchar_table;
221
      if (BOOL_VECTOR_P (object))
222
	return Qbool_vector;
223
      if (FRAMEP (object))
224
	return Qframe;
225
      if (HASH_TABLE_P (object))
Gerd Moellmann's avatar
Gerd Moellmann committed
226
	return Qhash_table;
227 228 229 230 231 232 233 234 235 236
      return Qvector;

    case Lisp_Float:
      return Qfloat;

    default:
      abort ();
    }
}

237 238 239
DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
       doc: /* Return t if OBJECT is a cons cell.  */)
     (object)
240
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
241
{
242
  if (CONSP (object))
Jim Blandy's avatar
Jim Blandy committed
243 244 245 246
    return Qt;
  return Qnil;
}

247
DEFUN ("atom", Fatom, Satom, 1, 1, 0,
248 249
       doc: /* Return t if OBJECT is not a cons cell.  This includes nil.  */)
     (object)
250
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
251
{
252
  if (CONSP (object))
Jim Blandy's avatar
Jim Blandy committed
253 254 255 256
    return Qnil;
  return Qt;
}

257
DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
Luc Teirlinck's avatar
Luc Teirlinck committed
258 259
       doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
Otherwise, return nil.  */)
260
     (object)
261
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
262
{
263
  if (CONSP (object) || NILP (object))
Jim Blandy's avatar
Jim Blandy committed
264 265 266 267
    return Qt;
  return Qnil;
}

268
DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
269 270
       doc: /* Return t if OBJECT is not a list.  Lists include nil.  */)
     (object)
271
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
272
{
273
  if (CONSP (object) || NILP (object))
Jim Blandy's avatar
Jim Blandy committed
274 275 276 277
    return Qnil;
  return Qt;
}

278
DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
279 280
       doc: /* Return t if OBJECT is a symbol.  */)
     (object)
281
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
282
{
283
  if (SYMBOLP (object))
Jim Blandy's avatar
Jim Blandy committed
284 285 286 287
    return Qt;
  return Qnil;
}

Dave Love's avatar
Dave Love committed
288 289 290
/* Define this in C to avoid unnecessarily consing up the symbol
   name.  */
DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
291 292 293 294
       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
295 296 297
     Lisp_Object object;
{
  if (SYMBOLP (object)
298
      && SREF (SYMBOL_NAME (object), 0) == ':'
299
      && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
Dave Love's avatar
Dave Love committed
300 301 302 303
    return Qt;
  return Qnil;
}

304
DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
305 306
       doc: /* Return t if OBJECT is a vector.  */)
     (object)
307
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
308
{
309
  if (VECTORP (object))
Jim Blandy's avatar
Jim Blandy committed
310 311 312 313
    return Qt;
  return Qnil;
}

314
DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
315 316
       doc: /* Return t if OBJECT is a string.  */)
     (object)
317
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
318
{
319
  if (STRINGP (object))
Jim Blandy's avatar
Jim Blandy committed
320 321 322 323
    return Qt;
  return Qnil;
}

324
DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
325 326 327
       1, 1, 0,
       doc: /* Return t if OBJECT is a multibyte string.  */)
     (object)
328 329 330 331 332 333 334 335
     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,
336 337
       doc: /* Return t if OBJECT is a char-table.  */)
     (object)
338 339 340 341 342 343 344
     Lisp_Object object;
{
  if (CHAR_TABLE_P (object))
    return Qt;
  return Qnil;
}

345 346
DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
       Svector_or_char_table_p, 1, 1, 0,
347 348
       doc: /* Return t if OBJECT is a char-table or vector.  */)
     (object)
349 350 351 352 353 354 355
     Lisp_Object object;
{
  if (VECTORP (object) || CHAR_TABLE_P (object))
    return Qt;
  return Qnil;
}

356 357 358
DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
       doc: /* Return t if OBJECT is a bool-vector.  */)
     (object)
359 360 361 362 363 364 365
     Lisp_Object object;
{
  if (BOOL_VECTOR_P (object))
    return Qt;
  return Qnil;
}

366 367 368
DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
       doc: /* Return t if OBJECT is an array (string or vector).  */)
     (object)
369
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
370
{
371
  if (ARRAYP (object))
Jim Blandy's avatar
Jim Blandy committed
372 373 374 375 376
    return Qt;
  return Qnil;
}

DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
377 378
       doc: /* Return t if OBJECT is a sequence (list or array).  */)
     (object)
379
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
380
{
381
  if (CONSP (object) || NILP (object) || ARRAYP (object))
Jim Blandy's avatar
Jim Blandy committed
382 383 384 385
    return Qt;
  return Qnil;
}

386 387 388
DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
       doc: /* Return t if OBJECT is an editor buffer.  */)
     (object)
389
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
390
{
391
  if (BUFFERP (object))
Jim Blandy's avatar
Jim Blandy committed
392 393 394 395
    return Qt;
  return Qnil;
}

396 397 398
DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
       doc: /* Return t if OBJECT is a marker (editor pointer).  */)
     (object)
399
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
400
{
401
  if (MARKERP (object))
Jim Blandy's avatar
Jim Blandy committed
402 403 404 405
    return Qt;
  return Qnil;
}

406 407 408
DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
       doc: /* Return t if OBJECT is a built-in function.  */)
     (object)
409
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
410
{
411
  if (SUBRP (object))
Jim Blandy's avatar
Jim Blandy committed
412 413 414 415
    return Qt;
  return Qnil;
}

Jim Blandy's avatar
Jim Blandy committed
416
DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
417 418 419
       1, 1, 0,
       doc: /* Return t if OBJECT is a byte-compiled function object.  */)
     (object)
420
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
421
{
422
  if (COMPILEDP (object))
Jim Blandy's avatar
Jim Blandy committed
423 424 425 426
    return Qt;
  return Qnil;
}

427
DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
428
       doc: /* Return t if OBJECT is a character or a string.  */)
429
     (object)
430
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
431
{
432
  if (CHARACTERP (object) || STRINGP (object))
Jim Blandy's avatar
Jim Blandy committed
433 434 435 436
    return Qt;
  return Qnil;
}

437 438 439
DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
       doc: /* Return t if OBJECT is an integer.  */)
     (object)
440
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
441
{
442
  if (INTEGERP (object))
Jim Blandy's avatar
Jim Blandy committed
443 444 445 446
    return Qt;
  return Qnil;
}

447
DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
448 449
       doc: /* Return t if OBJECT is an integer or a marker (editor pointer).  */)
     (object)
450
     register Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
451
{
452
  if (MARKERP (object) || INTEGERP (object))
Jim Blandy's avatar
Jim Blandy committed
453 454 455 456
    return Qt;
  return Qnil;
}

457
DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
458 459
       doc: /* Return t if OBJECT is a nonnegative integer.  */)
     (object)
460
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
461
{
462
  if (NATNUMP (object))
Jim Blandy's avatar
Jim Blandy committed
463 464 465 466 467
    return Qt;
  return Qnil;
}

DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
468 469
       doc: /* Return t if OBJECT is a number (floating point or integer).  */)
     (object)
470
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
471
{
472
  if (NUMBERP (object))
Jim Blandy's avatar
Jim Blandy committed
473
    return Qt;
Jim Blandy's avatar
Jim Blandy committed
474 475
  else
    return Qnil;
Jim Blandy's avatar
Jim Blandy committed
476 477 478 479
}

DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
       Snumber_or_marker_p, 1, 1, 0,
480 481
       doc: /* Return t if OBJECT is a number or a marker.  */)
     (object)
482
     Lisp_Object object;
Jim Blandy's avatar
Jim Blandy committed
483
{
484
  if (NUMBERP (object) || MARKERP (object))
Jim Blandy's avatar
Jim Blandy committed
485 486 487
    return Qt;
  return Qnil;
}
488 489

DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
490 491
       doc: /* Return t if OBJECT is a floating point number.  */)
     (object)
492
     Lisp_Object object;
493
{
494
  if (FLOATP (object))
495 496 497
    return Qt;
  return Qnil;
}
498

Jim Blandy's avatar
Jim Blandy committed
499 500 501 502

/* Extract and set components of lists */

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

Luc Teirlinck's avatar
Luc Teirlinck committed
506 507
See Info node `(elisp)Cons Cells' for a discussion of related basic
Lisp concepts such as car, cdr, cons cell and list.  */)
508
     (list)
Jim Blandy's avatar
Jim Blandy committed
509 510
     register Lisp_Object list;
{
511
  return CAR (list);
Jim Blandy's avatar
Jim Blandy committed
512 513 514
}

DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
515 516
       doc: /* Return the car of OBJECT if it is a cons cell, or else nil.  */)
     (object)
Jim Blandy's avatar
Jim Blandy committed
517 518
     Lisp_Object object;
{
519
  return CAR_SAFE (object);
Jim Blandy's avatar
Jim Blandy committed
520 521 522
}

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

Luc Teirlinck's avatar
Luc Teirlinck committed
526 527
See Info node `(elisp)Cons Cells' for a discussion of related basic
Lisp concepts such as cdr, car, cons cell and list.  */)
528
     (list)
Jim Blandy's avatar
Jim Blandy committed
529 530
     register Lisp_Object list;
{
531
  return CDR (list);
Jim Blandy's avatar
Jim Blandy committed
532 533 534
}

DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
535 536
       doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil.  */)
     (object)
Jim Blandy's avatar
Jim Blandy committed
537 538
     Lisp_Object object;
{
539
  return CDR_SAFE (object);
Jim Blandy's avatar
Jim Blandy committed
540 541 542
}

DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
543 544
       doc: /* Set the car of CELL to be NEWCAR.  Returns NEWCAR.  */)
     (cell, newcar)
Jim Blandy's avatar
Jim Blandy committed
545 546
     register Lisp_Object cell, newcar;
{
547
  CHECK_CONS (cell);
Jim Blandy's avatar
Jim Blandy committed
548
  CHECK_IMPURE (cell);
549
  XSETCAR (cell, newcar);
Jim Blandy's avatar
Jim Blandy committed
550 551 552 553
  return newcar;
}

DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
554 555
       doc: /* Set the cdr of CELL to be NEWCDR.  Returns NEWCDR.  */)
     (cell, newcdr)
Jim Blandy's avatar
Jim Blandy committed
556 557
     register Lisp_Object cell, newcdr;
{
558
  CHECK_CONS (cell);
Jim Blandy's avatar
Jim Blandy committed
559
  CHECK_IMPURE (cell);
560
  XSETCDR (cell, newcdr);
Jim Blandy's avatar
Jim Blandy committed
561 562 563 564 565
  return newcdr;
}

/* Extract and set components of symbols */

566 567 568
DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
       doc: /* Return t if SYMBOL's value is not void.  */)
     (symbol)
569
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
570 571
{
  Lisp_Object valcontents;
572
  CHECK_SYMBOL (symbol);
Jim Blandy's avatar
Jim Blandy committed
573

574
  valcontents = SYMBOL_VALUE (symbol);
Jim Blandy's avatar
Jim Blandy committed
575

576
  if (BUFFER_LOCAL_VALUEP (valcontents))
577
    valcontents = swap_in_symval_forwarding (symbol, valcontents);
Jim Blandy's avatar
Jim Blandy committed
578

579
  return (EQ (valcontents, Qunbound) ? Qnil : Qt);
Jim Blandy's avatar
Jim Blandy committed
580 581
}

582 583 584
DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
       doc: /* Return t if SYMBOL's function definition is not void.  */)
     (symbol)
585
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
586
{
587
  CHECK_SYMBOL (symbol);
588
  return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
Jim Blandy's avatar
Jim Blandy committed
589 590
}

591
DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
592 593
       doc: /* Make SYMBOL's value be void.
Return SYMBOL.  */)
594
     (symbol)
595
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
596
{
597
  CHECK_SYMBOL (symbol);
598
  if (SYMBOL_CONSTANT_P (symbol))
599
    xsignal1 (Qsetting_constant, symbol);
600 601
  Fset (symbol, Qunbound);
  return symbol;
Jim Blandy's avatar
Jim Blandy committed
602 603
}

604
DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
605 606
       doc: /* Make SYMBOL's function definition be void.
Return SYMBOL.  */)
607
     (symbol)
608
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
609
{
610
  CHECK_SYMBOL (symbol);
611
  if (NILP (symbol) || EQ (symbol, Qt))
612
    xsignal1 (Qsetting_constant, symbol);
613 614
  XSYMBOL (symbol)->function = Qunbound;
  return symbol;
Jim Blandy's avatar
Jim Blandy committed
615 616 617
}

DEFUN ("symbol-function", Fsymbol_function, Ssymbol_function, 1, 1, 0,
618 619
       doc: /* Return SYMBOL's function definition.  Error if that is void.  */)
     (symbol)
Jim Blandy's avatar
Jim Blandy committed
620
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
621
{
622
  CHECK_SYMBOL (symbol);
623 624 625
  if (!EQ (XSYMBOL (symbol)->function, Qunbound))
    return XSYMBOL (symbol)->function;
  xsignal1 (Qvoid_function, symbol);
Jim Blandy's avatar
Jim Blandy committed
626 627
}

628 629 630
DEFUN ("symbol-plist", Fsymbol_plist, Ssymbol_plist, 1, 1, 0,
       doc: /* Return SYMBOL's property list.  */)
     (symbol)
631
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
632
{
633
  CHECK_SYMBOL (symbol);
634
  return XSYMBOL (symbol)->plist;
Jim Blandy's avatar
Jim Blandy committed
635 636
}

637 638 639
DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
       doc: /* Return SYMBOL's name, a string.  */)
     (symbol)
640
     register Lisp_Object symbol;
Jim Blandy's avatar
Jim Blandy committed
641 642 643
{
  register Lisp_Object name;

644
  CHECK_SYMBOL (symbol);
645
  name = SYMBOL_NAME (symbol);
Jim Blandy's avatar
Jim Blandy committed
646 647 648 649
  return name;
}

DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
650 651
       doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.  */)
     (symbol, definition)
652
     register Lisp_Object symbol, definition;
653
{
654 655
  register Lisp_Object function;

656
  CHECK_SYMBOL (symbol);
657
  if (NILP (symbol) || EQ (symbol, Qt))
658
    xsignal1 (Qsetting_constant, symbol);
659 660 661 662 663 664 665 666 667

  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));

668
  XSYMBOL (symbol)->function = definition;
669
  /* Handle automatic advice activation */
670
  if (CONSP (XSYMBOL (symbol)->plist) && !NILP (Fget (symbol, Qad_advice_info)))
671
    {
672
      call2 (Qad_activate_internal, symbol, Qnil);
673
      definition = XSYMBOL (symbol)->function;
674
    }
675
  return definition;
Jim Blandy's avatar
Jim Blandy committed
676 677
}

678 679 680
extern Lisp_Object Qfunction_documentation;

DEFUN ("defalias", Fdefalias, Sdefalias, 2, 3, 0,
681
       doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION.
Richard M. Stallman's avatar
Richard M. Stallman committed
682 683 684 685
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.  */)
686 687
     (symbol, definition, docstring)
     register Lisp_Object symbol, definition, docstring;
688
{
689
  CHECK_SYMBOL (symbol);
690 691 692
  if (CONSP (XSYMBOL (symbol)->function)
      && EQ (XCAR (XSYMBOL (symbol)->function), Qautoload))
    LOADHIST_ATTACH (Fcons (Qt, symbol));
693
  definition = Ffset (symbol, definition);
694
  LOADHIST_ATTACH (Fcons (Qdefun, symbol));
695 696
  if (!NILP (docstring))
    Fput (symbol, Qfunction_documentation, docstring);
697
  return definition;
698 699
}

Jim Blandy's avatar
Jim Blandy committed
700
DEFUN ("setplist", Fsetplist, Ssetplist, 2, 2, 0,
Kenichi Handa's avatar
Kenichi Handa committed
701
       doc: /* Set SYMBOL's property list to NEWPLIST, and return NEWPLIST.  */)
702
     (symbol, newplist)
703
     register Lisp_Object symbol, newplist;
Jim Blandy's avatar
Jim Blandy committed
704
{
705
  CHECK_SYMBOL (symbol);
706
  XSYMBOL (symbol)->plist = newplist;
Jim Blandy's avatar
Jim Blandy committed
707 708
  return newplist;
}
Jim Blandy's avatar
Jim Blandy committed
709

710
DEFUN ("subr-arity", Fsubr_arity, Ssubr_arity, 1, 1, 0,
711 712 713 714 715 716
       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)
717 718 719
     Lisp_Object subr;
{
  short minargs, maxargs;
720
  CHECK_SUBR (subr);
721 722 723 724 725 726 727 728 729 730
  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
731 732 733 734 735 736 737
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;
738
  CHECK_SUBR (subr);
Stefan Monnier's avatar
Stefan Monnier committed
739 740 741 742
  name = XSUBR (subr)->symbol_name;
  return make_string (name, strlen (name));
}

Kenichi Handa's avatar
Kenichi Handa committed
743 744
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
745 746
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
747 748
     (cmd)
     Lisp_Object cmd;
749
{
750
  Lisp_Object fun = indirect_function (cmd); /* Check cycles.  */
751

752 753 754 755 756 757 758 759 760 761 762 763 764 765
  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
766 767 768

  if (SUBRP (fun))
    {
769 770 771 772 773
      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
774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793
    }
  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);
	}
    }
794 795 796
  return Qnil;
}

Jim Blandy's avatar
Jim Blandy committed
797

798 799 800 801 802 803 804 805
/***********************************************************************
		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.  */

Stefan Monnier's avatar
Stefan Monnier committed
806
struct Lisp_Symbol *
807
indirect_variable (symbol)
Stefan Monnier's avatar
Stefan Monnier committed
808
     struct Lisp_Symbol *symbol;
809
{
Stefan Monnier's avatar
Stefan Monnier committed
810
  struct Lisp_Symbol *tortoise, *hare;
811 812 813

  hare = tortoise = symbol;

Stefan Monnier's avatar
Stefan Monnier committed
814
  while (hare->indirect_variable)
815
    {
Stefan Monnier's avatar
Stefan Monnier committed
816 817
      hare = XSYMBOL (hare->value);
      if (!hare->indirect_variable)
818
	break;
819

Stefan Monnier's avatar
Stefan Monnier committed
820 821
      hare = XSYMBOL (hare->value);
      tortoise = XSYMBOL (tortoise->value);
822

Stefan Monnier's avatar
Stefan Monnier committed
823 824 825 826 827 828
      if (hare == tortoise)
	{
	  Lisp_Object tem;
	  XSETSYMBOL (tem, symbol);
	  xsignal1 (Qcyclic_variable_indirection, tem);
	}
829 830 831 832 833 834 835
    }

  return hare;
}


DEFUN ("indirect-variable", Findirect_variable, Sindirect_variable, 1, 1, 0,
836 837 838 839 840 841
       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)