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, 2007 Free Software Foundation, Inc.
    4: 
    5: This file is part of GNU Emacs.
    6: 
    7: GNU Emacs is free software; you can redistribute it and/or modify
    8: it under the terms of the GNU General Public License as published by
    9: the Free Software Foundation; either version 2, or (at your option)
   10: any later version.
   11: 
   12: GNU Emacs is distributed in the hope that it will be useful,
   13: but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: GNU General Public License for more details.
   16: 
   17: You should have received a copy of the GNU General Public License
   18: along with GNU Emacs; see the file COPYING.  If not, write to
   19: the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   20: Boston, MA 02110-1301, USA.  */
   21: 
   22: 
   23: #include <config.h>
   24: #include <signal.h>
   25: #include <stdio.h>
   26: #include "lisp.h"
   27: #include "puresize.h"
   28: #include "charset.h"
   29: #include "buffer.h"
   30: #include "keyboard.h"
   31: #include "frame.h"
   32: #include "syssignal.h"
   33: 
   34: #ifdef STDC_HEADERS
   35: #include <float.h>
   36: #endif
   37: 
   38: /* If IEEE_FLOATING_POINT isn't defined, default it from FLT_*. */
   39: #ifndef IEEE_FLOATING_POINT
   40: #if (FLT_RADIX == 2 && FLT_MANT_DIG == 24 \
   41:      && FLT_MIN_EXP == -125 && FLT_MAX_EXP == 128)
   42: #define IEEE_FLOATING_POINT 1
   43: #else
   44: #define IEEE_FLOATING_POINT 0
   45: #endif
   46: #endif
   47: 
   48: /* Work around a problem that happens because math.h on hpux 7
   49:    defines two static variables--which, in Emacs, are not really static,
   50:    because `static' is defined as nothing.  The problem is that they are
   51:    here, in floatfns.c, and in lread.c.
   52:    These macros prevent the name conflict.  */
   53: #if defined (HPUX) && !defined (HPUX8)
   54: #define _MAXLDBL data_c_maxldbl
   55: #define _NMAXLDBL data_c_nmaxldbl
   56: #endif
   57: 
   58: #include <math.h>
   59: 
   60: #if !defined (atof)
   61: extern double atof ();
   62: #endif /* !atof */
   63: 
   64: Lisp_Object Qnil, Qt, Qquote, Qlambda, Qsubr, Qunbound;
   65: Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
   66: Lisp_Object Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
   67: Lisp_Object Qvoid_variable, Qvoid_function, Qcyclic_function_indirection;
   68: Lisp_Object Qcyclic_variable_indirection, Qcircular_list;
   69: Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
   70: Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
   71: Lisp_Object Qend_of_file, Qarith_error, Qmark_inactive;
   72: Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
   73: Lisp_Object Qtext_read_only;
   74: 
   75: Lisp_Object Qintegerp, Qnatnump, Qwholenump, Qsymbolp, Qlistp, Qconsp;
   76: Lisp_Object Qstringp, Qarrayp, Qsequencep, Qbufferp;
   77: Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
   78: Lisp_Object Qbuffer_or_string_p, Qkeywordp;
   79: Lisp_Object Qboundp, Qfboundp;
   80: Lisp_Object Qchar_table_p, Qvector_or_char_table_p;
   81: 
   82: Lisp_Object Qcdr;
   83: Lisp_Object Qad_advice_info, Qad_activate_internal;
   84: 
   85: Lisp_Object Qrange_error, Qdomain_error, Qsingularity_error;
   86: Lisp_Object Qoverflow_error, Qunderflow_error;
   87: 
   88: Lisp_Object Qfloatp;
   89: Lisp_Object Qnumberp, Qnumber_or_marker_p;
   90: 
   91: Lisp_Object Qinteger;
   92: static Lisp_Object Qsymbol, Qstring, Qcons, Qmarker, Qoverlay;
   93: static Lisp_Object Qfloat, Qwindow_configuration, Qwindow;
   94: Lisp_Object Qprocess;
   95: static Lisp_Object Qcompiled_function, Qbuffer, Qframe, Qvector;
   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: void
  105: circular_list_error (list)
  106:      Lisp_Object list;
  107: {
  108:   xsignal (Qcircular_list, list);
  109: }
  110: 
  111: 
  112: Lisp_Object
  113: wrong_type_argument (predicate, value)
  114:      register Lisp_Object predicate, value;
  115: {
  116:   /* If VALUE is not even a valid Lisp object, abort here
  117:      where we can get a backtrace showing where it came from.  */
  118:   if ((unsigned int) XGCTYPE (value) >= Lisp_Type_Limit)
  119:     abort ();
  120: 
  121:   xsignal2 (Qwrong_type_argument, predicate, value);
  122: }
  123: 
  124: void
  125: pure_write_error ()
  126: {
  127:   error ("Attempt to modify read-only object");
  128: }
  129: 
  130: void
  131: args_out_of_range (a1, a2)
  132:      Lisp_Object a1, a2;
  133: {
  134:   xsignal2 (Qargs_out_of_range, a1, a2);
  135: }
  136: 
  137: void
  138: args_out_of_range_3 (a1, a2, a3)
  139:      Lisp_Object a1, a2, a3;
  140: {
  141:   xsignal3 (Qargs_out_of_range, a1, a2, a3);
  142: }
  143: 
  144: /* On some machines, XINT needs a temporary location.
  145:    Here it is, in case it is needed.  */
  146: 
  147: int sign_extend_temp;
  148: 
  149: /* On a few machines, XINT can only be done by calling this.  */
  150: 
  151: int
  152: sign_extend_lisp_int (num)
  153:      EMACS_INT num;
  154: {
  155:   if (num & (((EMACS_INT) 1) << (VALBITS - 1)))
  156:     return num | (((EMACS_INT) (-1)) << VALBITS);
  157:   else
  158:     return num & ((((EMACS_INT) 1) << VALBITS) - 1);
  159: }
  160: ^L
  161: /* Data type predicates */
  162: 
  163: DEFUN ("eq", Feq, Seq, 2, 2, 0,
  164:        doc: /* Return t if the two args are the same Lisp object.  */)
  165:      (obj1, obj2)
  166:      Lisp_Object obj1, obj2;
  167: {
  168:   if (EQ (obj1, obj2))
  169:     return Qt;
  170:   return Qnil;
  171: }
  172: 
  173: DEFUN ("null", Fnull, Snull, 1, 1, 0,
  174:        doc: /* Return t if OBJECT is nil.  */)
  175:      (object)
  176:      Lisp_Object object;
  177: {
  178:   if (NILP (object))
  179:     return Qt;
  180:   return Qnil;
  181: }
  182: 
  183: DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
  184:        doc: /* Return a symbol representing the type of OBJECT.
  185: The symbol returned names the object's basic type;
  186: for example, (type-of 1) returns `integer'.  */)
  187:      (object)
  188:      Lisp_Object object;
  189: {
  190:   switch (XGCTYPE (object))
  191:     {
  192:     case Lisp_Int:
  193:       return Qinteger;
  194: 
  195:     case Lisp_Symbol:
  196:       return Qsymbol;
  197: 
  198:     case Lisp_String:
  199:       return Qstring;
  200: 
  201:     case Lisp_Cons:
  202:       return Qcons;
  203: 
  204:     case Lisp_Misc:
  205:       switch (XMISCTYPE (object))
  206:         {
  207:         case Lisp_Misc_Marker:
  208:           return Qmarker;
  209:         case Lisp_Misc_Overlay:
  210:           return Qoverlay;
  211:         case Lisp_Misc_Float:
  212:           return Qfloat;
  213:         }
  214:       abort ();
  215: 
  216:     case Lisp_Vectorlike:
  217:       if (GC_WINDOW_CONFIGURATIONP (object))
  218:         return Qwindow_configuration;
  219:       if (GC_PROCESSP (object))
  220:         return Qprocess;
  221:       if (GC_WINDOWP (object))
  222:         return Qwindow;
  223:       if (GC_SUBRP (object))
  224:         return Qsubr;
  225:       if (GC_COMPILEDP (object))
  226:         return Qcompiled_function;
  227:       if (GC_BUFFERP (object))
  228:         return Qbuffer;
  229:       if (GC_CHAR_TABLE_P (object))
  230:         return Qchar_table;
  231:       if (GC_BOOL_VECTOR_P (object))
  232:         return Qbool_vector;
  233:       if (GC_FRAMEP (object))
  234:         return Qframe;
  235:       if (GC_HASH_TABLE_P (object))
  236:         return Qhash_table;
  237:       return Qvector;
  238: 
  239:     case Lisp_Float:
  240:       return Qfloat;
  241: 
  242:     default:
  243:       abort ();
  244:     }
  245: }
  246: 
  247: DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0,
  248:        doc: /* Return t if OBJECT is a cons cell.  */)
  249:      (object)
  250:      Lisp_Object object;
  251: {
  252:   if (CONSP (object))
  253:     return Qt;
  254:   return Qnil;
  255: }
  256: 
  257: DEFUN ("atom", Fatom, Satom, 1, 1, 0,
  258:        doc: /* Return t if OBJECT is not a cons cell.  This includes nil.  */)
  259:      (object)
  260:      Lisp_Object object;
  261: {
  262:   if (CONSP (object))
  263:     return Qnil;
  264:   return Qt;
  265: }
  266: 
  267: DEFUN ("listp", Flistp, Slistp, 1, 1, 0,
  268:        doc: /* Return t if OBJECT is a list, that is, a cons cell or nil.
  269: Otherwise, return nil.  */)
  270:      (object)
  271:      Lisp_Object object;
  272: {
  273:   if (CONSP (object) || NILP (object))
  274:     return Qt;
  275:   return Qnil;
  276: }
  277: 
  278: DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
  279:        doc: /* Return t if OBJECT is not a list.  Lists include nil.  */)
  280:      (object)
  281:      Lisp_Object object;
  282: {
  283:   if (CONSP (object) || NILP (object))
  284:     return Qnil;
  285:   return Qt;
  286: }
  287: ^L
  288: DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0,
  289:        doc: /* Return t if OBJECT is a symbol.  */)
  290:      (object)
  291:      Lisp_Object object;
  292: {
  293:   if (SYMBOLP (object))
  294:     return Qt;
  295:   return Qnil;
  296: }
  297: 
  298: /* Define this in C to avoid unnecessarily consing up the symbol
  299:    name.  */
  300: DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0,
  301:        doc: /* Return t if OBJECT is a keyword.
  302: This means that it is a symbol with a print name beginning with `:'
  303: interned in the initial obarray.  */)
  304:      (object)
  305:      Lisp_Object object;
  306: {
  307:   if (SYMBOLP (object)
  308:       && SREF (SYMBOL_NAME (object), 0) == ':'
  309:       && SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (object))
  310:     return Qt;
  311:   return Qnil;
  312: }
  313: 
  314: DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0,
  315:        doc: /* Return t if OBJECT is a vector.  */)
  316:      (object)
  317:      Lisp_Object object;
  318: {
  319:   if (VECTORP (object))
  320:     return Qt;
  321:   return Qnil;
  322: }
  323: 
  324: DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0,
  325:        doc: /* Return t if OBJECT is a string.  */)
  326:      (object)
  327:      Lisp_Object object;
  328: {
  329:   if (STRINGP (object))
  330:     return Qt;
  331:   return Qnil;
  332: }
  333: 
  334: DEFUN ("multibyte-string-p", Fmultibyte_string_p, Smultibyte_string_p,
  335:        1, 1, 0,
  336:        doc: /* Return t if OBJECT is a multibyte string.  */)
  337:      (object)
  338:      Lisp_Object object;
  339: {
  340:   if (STRINGP (object) && STRING_MULTIBYTE (object))
  341:     return Qt;
  342:   return Qnil;
  343: }
  344: 
  345: DEFUN ("char-table-p", Fchar_table_p, Schar_table_p, 1, 1, 0,
  346:        doc: /* Return t if OBJECT is a char-table.  */)
  347:      (object)
  348:      Lisp_Object object;
  349: {
  350:   if (CHAR_TABLE_P (object))
  351:     return Qt;
  352:   return Qnil;
  353: }
  354: 
  355: DEFUN ("vector-or-char-table-p", Fvector_or_char_table_p,
  356:        Svector_or_char_table_p, 1, 1, 0,
  357:        doc: /* Return t if OBJECT is a char-table or vector.  */)
  358:      (object)
  359:      Lisp_Object object;
  360: {
  361:   if (VECTORP (object) || CHAR_TABLE_P (object))
  362:     return Qt;
  363:   return Qnil;
  364: }
  365: 
  366: DEFUN ("bool-vector-p", Fbool_vector_p, Sbool_vector_p, 1, 1, 0,
  367:        doc: /* Return t if OBJECT is a bool-vector.  */)
  368:      (object)
  369:      Lisp_Object object;
  370: {
  371:   if (BOOL_VECTOR_P (object))
  372:     return Qt;
  373:   return Qnil;
  374: }
  375: 
  376: DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
  377:        doc: /* Return t if OBJECT is an array (string or vector).  */)
  378:      (object)
  379:      Lisp_Object object;
  380: {
  381:   if (ARRAYP (object))
  382:     return Qt;
  383:   return Qnil;
  384: }
  385: 
  386: DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
  387:        doc: /* Return t if OBJECT is a sequence (list or array).  */)
  388:      (object)
  389:      register Lisp_Object object;
  390: {
  391:   if (CONSP (object) || NILP (object) || ARRAYP (object))
  392:     return Qt;
  393:   return Qnil;
  394: }
  395: 
  396: DEFUN ("bufferp", Fbufferp, Sbufferp, 1, 1, 0,
  397:        doc: /* Return t if OBJECT is an editor buffer.  */)
  398:      (object)
  399:      Lisp_Object object;
  400: {
  401:   if (BUFFERP (object))
  402:     return Qt;
  403:   return Qnil;
  404: }
  405: 
  406: DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
  407:        doc: /* Return t if OBJECT is a marker (editor pointer).  */)
  408:      (object)
  409:      Lisp_Object object;
  410: {
  411:   if (MARKERP (object))
  412:     return Qt;
  413:   return Qnil;
  414: }
  415: 
  416: DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0,
  417:        doc: /* Return t if OBJECT is a built-in function.  */)
  418:      (object)
  419:      Lisp_Object object;
  420: {
  421:   if (SUBRP (object))
  422:     return Qt;
  423:   return Qnil;
  424: }
  425: 
  426: DEFUN ("byte-code-function-p", Fbyte_code_function_p, Sbyte_code_function_p,
  427:        1, 1, 0,
  428:        doc: /* Return t if OBJECT is a byte-compiled function object.  */)
  429:      (object)
  430:      Lisp_Object object;
  431: {
  432:   if (COMPILEDP (object))
  433:     return Qt;
  434:   return Qnil;
  435: }
  436: 
  437: DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
  438:        doc: /* Return t if OBJECT is a character (an integer) or a string.  */)
  439:      (object)
  440:      register Lisp_Object object;
  441: {
  442:   if (INTEGERP (object) || STRINGP (object))
  443:     return Qt;
  444:   return Qnil;
  445: }
  446: ^L
  447: DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
  448:        doc: /* Return t if OBJECT is an integer.  */)
  449:      (object)
  450:      Lisp_Object object;
  451: {
  452:   if (INTEGERP (object))
  453:     return Qt;
  454:   return Qnil;
  455: }
  456: 
  457: DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p, 1, 1, 0,
  458:        doc: /* Return t if OBJECT is an integer or a marker (editor pointer).  */)
  459:      (object)
  460:      register Lisp_Object object;
  461: {
  462:   if (MARKERP (object) || INTEGERP (object))
  463:     return Qt;
  464:   return Qnil;
  465: }
  466: 
  467: DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
  468:        doc: /* Return t if OBJECT is a nonnegative integer.  */)
  469:      (object)
  470:      Lisp_Object object;
  471: {
  472:   if (NATNUMP (object))
  473:     return Qt;
  474:   return Qnil;
  475: }
  476: 
  477: DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
  478:        doc: /* Return t if OBJECT is a number (floating point or integer).  */)
  479:      (object)
  480:      Lisp_Object object;
  481: {
  482:   if (NUMBERP (object))
  483:     return Qt;
  484:   else
  485:     return Qnil;
  486: }
  487: 
  488: DEFUN ("number-or-marker-p", Fnumber_or_marker_p,
  489:        Snumber_or_marker_p, 1, 1, 0,
  490:        doc: /* Return t if OBJECT is a number or a marker.  */)
  491:      (object)
  492:      Lisp_Object object;
  493: {
  494:   if (NUMBERP (object) || MARKERP (object))
  495:     return Qt;
  496:   return Qnil;
  497: }
  498: 
  499: DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
  500:        doc: /* Return t if OBJECT is a floating point number.  */)
  501:      (object)
  502:      Lisp_Object object;
  503: {
  504:   if (FLOATP (object))
  505:     return Qt;
  506:   return Qnil;
  507: }
  508: 
  509: ^L
  510: /* Extract and set components of lists */
  511: 
  512: DEFUN ("car", Fcar, Scar, 1, 1, 0,
  513:        doc: /* Return the car of LIST.  If arg is nil, return nil.
  514: Error if arg is not nil and not a cons cell.  See also `car-safe'.
  515: 
  516: See Info node `(elisp)Cons Cells' for a discussion of related basic
  517: Lisp concepts such as car, cdr, cons cell and list.  */)
  518:      (list)
  519:      register Lisp_Object list;
  520: {
  521:   return CAR (list);
  522: }
  523: 
  524: DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
  525:        doc: /* Return the car of OBJECT if it is a cons cell, or else nil.  */)
  526:      (object)
  527:      Lisp_Object object;
  528: {
  529:   return CAR_SAFE (object);
  530: }
  531: 
  532: DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
  533:        doc: /* Return the cdr of LIST.  If arg is nil, return nil.
  534: Error if arg is not nil and not a cons cell.  See also `cdr-safe'.
  535: 
  536: See Info node `(elisp)Cons Cells' for a discussion of related basic
  537: Lisp concepts such as cdr, car, cons cell and list.  */)
  538:      (list)
  539:      register Lisp_Object list;
  540: {
  541:   return CDR (list);
  542: }
  543: 
  544: DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
  545:        doc: /* Return the cdr of OBJECT if it is a cons cell, or else nil.  */)
  546:      (object)
  547:      Lisp_Object object;
  548: {
  549:   return CDR_SAFE (object);
  550: }
  551: 
  552: DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
  553:        doc: /* Set the car of CELL to be NEWCAR.  Returns NEWCAR.  */)
  554:      (cell, newcar)
  555:      register Lisp_Object cell, newcar;
  556: {
  557:   CHECK_CONS (cell);
  558:   CHECK_IMPURE (cell);
  559:   XSETCAR (cell, newcar);
  560:   return newcar;
  561: }
  562: 
  563: DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
  564:        doc: /* Set the cdr of CELL to be NEWCDR.  Returns NEWCDR.  */)
  565:      (cell, newcdr)
  566:      register Lisp_Object cell, newcdr;
  567: {
  568:   CHECK_CONS (cell);
  569:   CHECK_IMPURE (cell);
  570:   XSETCDR (cell, newcdr);
  571:   return newcdr;
  572: }
  573: ^L
  574: /* Extract and set components of symbols */
  575: 
  576: DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0,
  577:        doc: /* Return t if SYMBOL's value is not void.  */)
  578:      (symbol)
  579:      register Lisp_Object symbol;
  580: {
  581:   Lisp_Object valcontents;
  582:   CHECK_SYMBOL (symbol);
  583: 
  584:   valcontents = SYMBOL_VALUE (symbol);
  585: 
  586:   if (BUFFER_LOCAL_VALUEP (valcontents)
  587:       || SOME_BUFFER_LOCAL_VALUEP (valcontents))
  588:     valcontents = swap_in_symval_forwarding (symbol, valcontents);
  589: 
  590:   return (EQ (valcontents, Qunbound) ? Qnil : Qt);
  591: }
  592: 
  593: DEFUN ("fboundp", Ffboundp, Sfboundp, 1, 1, 0,
  594:        doc: /* Return t if SYMBOL's function definition is not void.  */)
  595:      (symbol)
  596:      register Lisp_Object symbol;
  597: {
  598:   CHECK_SYMBOL (symbol);
  599:   return (EQ (XSYMBOL (symbol)->function, Qunbound) ? Qnil : Qt);
  600: }
  601: 
  602: DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0,
  603:        doc: /* Make SYMBOL's value be void.
  604: Return SYMBOL.  */)
  605:      (symbol)
  606:      register Lisp_Object symbol;
  607: {
  608:   CHECK_SYMBOL (symbol);
  609:   if (SYMBOL_CONSTANT_P (symbol))
  610:     xsignal1 (Qsetting_constant, symbol);
  611:   Fset (symbol, Qunbound);
  612:   return symbol;
  613: }
  614: 
  615: DEFUN ("fmakunbound", Ffmakunbound, Sfmakunbound, 1, 1, 0,
  616:        doc: /* Make SYMBOL's function definition be void.
  617: Return SYMBOL.  */)
  618:      (symbol)
  619:      register Lisp_Object symbol;
  620: {
  621:   CHECK_SYMBOL (symbol);
  622:   if (NILP (symbol) || EQ (symbol,