home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / src / data.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-18  |  41.5 KB  |  1,644 lines
  1. /* Primitive operations on Lisp data types for XEmacs Lisp interpreter.
  2.    Copyright (C) 1985, 1986, 1988, 1992, 1993, 1994
  3.    Free Software Foundation, Inc.
  4.  
  5. This file is part of XEmacs.
  6.  
  7. XEmacs is free software; you can redistribute it and/or modify it
  8. under the terms of the GNU General Public License as published by the
  9. Free Software Foundation; either version 2, or (at your option) any
  10. later version.
  11.  
  12. XEmacs is distributed in the hope that it will be useful, but WITHOUT
  13. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15. for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with XEmacs; see the file COPYING.  If not, write to the Free
  19. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  20.  
  21. /* Synched up with: Mule 2.0, FSF 19.28.  Some of FSF's data.c is in
  22.    XEmacs' symbols.c. */
  23.  
  24. /* This file has been Mule-ized. */
  25.  
  26. #include <config.h>
  27. #include "lisp.h"
  28.  
  29. #include "bytecode.h"
  30.  
  31. #include "syssignal.h"
  32. #ifdef LISP_FLOAT_TYPE
  33. /* Need to define a differentiating symbol -- see sysfloat.h */
  34. # define THIS_FILENAME data_c
  35. # include "sysfloat.h"
  36. #endif /* LISP_FLOAT_TYPE */
  37.  
  38. Lisp_Object Qnil, Qt, Qquote, Qlambda, Qfunction, Qunbound;
  39. Lisp_Object Qerror_conditions, Qerror_message, Qtop_level;
  40. Lisp_Object Qsignal, Qerror, Qquit, Qwrong_type_argument, Qargs_out_of_range;
  41. Lisp_Object Qvoid_variable, Qcyclic_variable_indirection;
  42. Lisp_Object Qvoid_function, Qcyclic_function_indirection;
  43. Lisp_Object Qsetting_constant, Qinvalid_read_syntax;
  44. Lisp_Object Qinvalid_function, Qwrong_number_of_arguments, Qno_catch;
  45. Lisp_Object Qend_of_file;
  46. Lisp_Object Qarith_error, Qrange_error, Qdomain_error;
  47. Lisp_Object Qsingularity_error, Qoverflow_error, Qunderflow_error;
  48. Lisp_Object Qbeginning_of_buffer, Qend_of_buffer, Qbuffer_read_only;
  49. Lisp_Object Qintegerp, Qnatnump, Qsymbolp, Qkeywordp, Qlistp, Qconsp, Qsubrp;
  50. Lisp_Object Qcharacterp, Qstringp, Qarrayp, Qsequencep, Qbufferp, Qbytecodep;
  51. Lisp_Object Qchar_or_string_p, Qmarkerp, Qinteger_or_marker_p, Qvectorp;
  52. Lisp_Object Qboundp, Qfboundp;
  53.  
  54. /* Qstring, Qinteger, Qsymbol, Qvector defined in general.c */
  55. Lisp_Object Qcons, Qkeyword;
  56.  
  57. Lisp_Object Qcdr;
  58.  
  59. Lisp_Object Qignore;
  60.  
  61. #ifdef LISP_FLOAT_TYPE
  62. Lisp_Object Qfloatp;
  63. #endif
  64. Lisp_Object Qnumberp, Qnumber_or_marker_p;
  65.  
  66.  
  67. Lisp_Object
  68. wrong_type_argument (Lisp_Object predicate, Lisp_Object value)
  69. {
  70.   /* This function can GC */
  71.   REGISTER Lisp_Object tem;
  72.   do
  73.     {
  74. #ifdef MOCKLISP_SUPPORT
  75.       if (!EQ (Vmocklisp_arguments, Qt))
  76.     {
  77.      if (STRINGP (value) &&
  78.          (EQ (predicate, Qintegerp) ||
  79.           EQ (predicate, Qinteger_or_marker_p)))
  80.        return Fstring_to_number (value);
  81.      if (INTP (value) && EQ (predicate, Qstringp))
  82.        return Fnumber_to_string (value);
  83.     }
  84. #endif
  85.       value = Fsignal (Qwrong_type_argument, list2 (predicate, value));
  86.       tem = call1 (predicate, value);
  87.     }
  88.   while (NILP (tem));
  89.   return value;
  90. }
  91.  
  92. DEFUN ("wrong-type-argument", Fwrong_type_argument, Swrong_type_argument,
  93.        2, 2, 0,
  94.        "Signal an error until the correct type value is given by the user.\n\
  95. This function loops, signalling a continuable `wrong-type-argument' error\n\
  96. with PREDICATE and VALUE as the data associated with the error and then\n\
  97. calling PREDICATE on the returned value, until the value gotten satisfies\n\
  98. PREDICATE.  At that point, the gotten value is returned.")
  99.   (predicate, value)
  100.      Lisp_Object predicate, value;
  101. {
  102.   return wrong_type_argument (predicate, value);
  103. }
  104.  
  105. DOESNT_RETURN
  106. pure_write_error (void)
  107. {
  108.   error ("Attempt to modify read-only object");
  109. }
  110.  
  111. DOESNT_RETURN
  112. args_out_of_range (Lisp_Object a1, Lisp_Object a2)
  113. {
  114.   signal_error (Qargs_out_of_range, list2 (a1, a2));
  115. }
  116.  
  117. DOESNT_RETURN
  118. args_out_of_range_3 (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3)
  119. {
  120.   signal_error (Qargs_out_of_range, list3 (a1, a2, a3));
  121. }
  122.  
  123. void
  124. check_int_range (int val, int min, int max)
  125. {
  126.   if (val < min || val > max)
  127.     args_out_of_range_3 (make_number (val), make_number (min),
  128.              make_number (max));
  129. }
  130.  
  131. #ifndef make_number
  132. Lisp_Object
  133. make_number (LISP_WORD_TYPE num)
  134. {
  135.   Lisp_Object val;
  136.   /* Don't use XSETINT here -- it's defined in terms of make_number ().  */
  137.   XSETOBJ (val, Lisp_Int, num);
  138.   return val;
  139. }
  140. #endif /* ! defined (make_number) */
  141.  
  142. /* On some machines, XINT needs a temporary location.
  143.    Here it is, in case it is needed.  */
  144.  
  145. LISP_WORD_TYPE sign_extend_temp;
  146.  
  147. /* On a few machines, XINT can only be done by calling this.  */
  148. /* XEmacs:  only used by m/convex.h */
  149. int sign_extend_lisp_int (LISP_WORD_TYPE num);
  150. int
  151. sign_extend_lisp_int (LISP_WORD_TYPE num)
  152. {
  153.   if (num & (1L << (VALBITS - 1)))
  154.     return num | ((-1L) << VALBITS);
  155.   else
  156.     return num & ((1L << VALBITS) - 1);
  157. }
  158.  
  159. /* Data type predicates */
  160.  
  161. DEFUN ("eq", Feq, Seq, 2, 2, 0,
  162.   "T if the two args are the same Lisp object.")
  163.   (obj1, obj2)
  164.      Lisp_Object obj1, obj2;
  165. {
  166.   if (EQ (obj1, obj2))
  167.     return Qt;
  168.   return Qnil;
  169. }
  170.  
  171. DEFUN ("null", Fnull, Snull, 1, 1, 0, "T if OBJECT is nil.")
  172.   (object)
  173.      Lisp_Object object;
  174. {
  175.   if (NILP (object))
  176.     return Qt;
  177.   return Qnil;
  178. }
  179.  
  180. DEFUN ("consp", Fconsp, Sconsp, 1, 1, 0, "T if OBJECT is a cons cell.")
  181.   (object)
  182.      Lisp_Object object;
  183. {
  184.   if (CONSP (object))
  185.     return Qt;
  186.   return Qnil;
  187. }
  188.  
  189. DEFUN ("atom", Fatom, Satom, 1, 1, 0, "T if OBJECT is not a cons cell.  This includes nil.")
  190.   (object)
  191.      Lisp_Object object;
  192. {
  193.   if (CONSP (object))
  194.     return Qnil;
  195.   return Qt;
  196. }
  197.  
  198. DEFUN ("listp", Flistp, Slistp, 1, 1, 0, "T if OBJECT is a list.  This includes nil.")
  199.   (object)
  200.      Lisp_Object object;
  201. {
  202.   if (CONSP (object) || NILP (object))
  203.     return Qt;
  204.   return Qnil;
  205. }
  206.  
  207. DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, "T if OBJECT is not a list.  Lists include nil.")
  208.   (object)
  209.      Lisp_Object object;
  210. {
  211.   if (CONSP (object) || NILP (object))
  212.     return Qnil;
  213.   return Qt;
  214. }
  215.  
  216. DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, "T if OBJECT is a symbol.")
  217.   (object)
  218.      Lisp_Object object;
  219. {
  220.   if (SYMBOLP (object))
  221.     return Qt;
  222.   return Qnil;
  223. }
  224.  
  225. DEFUN ("keywordp", Fkeywordp, Skeywordp, 1, 1, 0, "T if OBJECT is a keyword.")
  226.   (object)
  227.      Lisp_Object object;
  228. {
  229.   if (KEYWORDP (object))
  230.     return Qt;
  231.   return Qnil;
  232. }
  233.  
  234. DEFUN ("vectorp", Fvectorp, Svectorp, 1, 1, 0, "T if OBJECT is a vector.")
  235.   (object)
  236.      Lisp_Object object;
  237. {
  238.   if (VECTORP (object))
  239.     return Qt;
  240.   return Qnil;
  241. }
  242.  
  243. DEFUN ("stringp", Fstringp, Sstringp, 1, 1, 0, "T if OBJECT is a string.")
  244.   (object)
  245.      Lisp_Object object;
  246. {
  247.   if (STRINGP (object))
  248.     return Qt;
  249.   return Qnil;
  250. }
  251.  
  252. DEFUN ("arrayp", Farrayp, Sarrayp, 1, 1, 0,
  253.        "T if OBJECT is an array (string or vector).")
  254.   (object)
  255.      Lisp_Object object;
  256. {
  257.   if (VECTORP (object) || STRINGP (object))
  258.     return Qt;
  259.   return Qnil;
  260. }
  261.  
  262. DEFUN ("sequencep", Fsequencep, Ssequencep, 1, 1, 0,
  263.   "T if OBJECT is a sequence (list or array).")
  264.   (object)
  265.      Lisp_Object object;
  266. {
  267.   if (CONSP (object) || NILP (object) 
  268.       || VECTORP (object) || STRINGP (object))
  269.     return Qt;
  270.   return Qnil;
  271. }
  272.  
  273. DEFUN ("markerp", Fmarkerp, Smarkerp, 1, 1, 0,
  274.        "T if OBJECT is a marker (editor pointer).")
  275.   (object)
  276.      Lisp_Object object;
  277. {
  278.   if (MARKERP (object))
  279.     return Qt;
  280.   return Qnil;
  281. }
  282.  
  283. DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, "T if OBJECT is a built-in function.")
  284.   (object)
  285.      Lisp_Object object;
  286. {
  287.   if (SUBRP (object))
  288.     return Qt;
  289.   return Qnil;
  290. }
  291.  
  292. DEFUN ("subr-min-args", Fsubr_min_args, Ssubr_min_args, 1, 1, 0,
  293.    "Return minimum number of args built-in function SUBR may be called with.")
  294.   (subr)
  295.      Lisp_Object subr;
  296. {
  297.   CHECK_SUBR (subr, 0);
  298.   return make_number (XSUBR (subr)->min_args);
  299. }
  300.  
  301. DEFUN ("subr-max-args", Fsubr_max_args, Ssubr_max_args, 1, 1, 0,
  302.  "Return maximum number of args built-in function SUBR may be called with,\n\
  303. or nil if it takes an arbitrary number of arguments (or is a special form).")
  304.   (subr)
  305.      Lisp_Object subr;
  306. {
  307.   int nargs;
  308.   CHECK_SUBR (subr, 0);
  309.   nargs = XSUBR (subr)->max_args;
  310.   if (nargs == MANY || nargs == UNEVALLED)
  311.     return Qnil;
  312.   else
  313.     return make_number (nargs);
  314. }
  315.  
  316. DEFUN ("compiled-function-p", Fcompiled_function_p, Scompiled_function_p, 1, 1, 0,
  317.        "t if OBJECT is a byte-compiled function object.")
  318.   (object)
  319.      Lisp_Object object;
  320. {
  321.   if (BYTECODEP (object))
  322.     return Qt;
  323.   return Qnil;
  324. }
  325.  
  326.  
  327. DEFUN ("characterp", Fcharacterp, Scharacterp, 1, 1, 0,
  328.        "t if OBJECT is a character.\n\
  329. A character is an integer that can be inserted into a buffer with\n\
  330. `insert-char'.  If Mule support was compiled in, only certain integers\n\
  331. are valid characters.  Otherwise, all integers are considered valid\n\
  332. characters and are modded with 256 to get the actual character to use.")
  333.   (object)
  334.      Lisp_Object object;
  335. {
  336.   if (CHARP (object))
  337.     return Qt;
  338.   return Qnil;
  339. }
  340.  
  341. DEFUN ("char-or-string-p", Fchar_or_string_p, Schar_or_string_p, 1, 1, 0,
  342.        "t if OBJECT is a character or a string.")
  343.   (object)
  344.      Lisp_Object object;
  345. {
  346.   if (CHARP (object) || STRINGP (object))
  347.     return Qt;
  348.   return Qnil;
  349. }
  350.  
  351. DEFUN ("integerp", Fintegerp, Sintegerp, 1, 1, 0,
  352.        "t if OBJECT is an integer.")
  353.   (object)
  354.      Lisp_Object object;
  355. {
  356.   if (INTP (object))
  357.     return Qt;
  358.   return Qnil;
  359. }
  360.  
  361. DEFUN ("integer-or-marker-p", Finteger_or_marker_p, Sinteger_or_marker_p,
  362.        1, 1, 0,
  363.        "t if OBJECT is an integer or a marker (editor pointer).")
  364.   (object)
  365.      Lisp_Object object;
  366. {
  367.   if (INTP (object) || MARKERP (object))
  368.     return Qt;
  369.   return Qnil;
  370. }
  371.  
  372. DEFUN ("natnump", Fnatnump, Snatnump, 1, 1, 0,
  373.        "t if OBJECT is a nonnegative integer.")
  374.   (object)
  375.      Lisp_Object object;
  376. {
  377.   if (NATNUMP (object))
  378.     return Qt;
  379.   return Qnil;
  380. }
  381.  
  382. DEFUN ("numberp", Fnumberp, Snumberp, 1, 1, 0,
  383.        "t if OBJECT is a number (floating point or integer).")
  384.   (object)
  385.      Lisp_Object object;
  386. {
  387.   if (INT_OR_FLOATP (object))
  388.     return Qt;
  389.   return Qnil;
  390. }
  391.  
  392. DEFUN ("number-or-marker-p", Fnumber_or_marker_p, Snumber_or_marker_p, 1, 1, 0,
  393.        "t if OBJECT is a number or a marker.")
  394.   (object)
  395.      Lisp_Object object;
  396. {
  397.   if (INT_OR_FLOATP (object)
  398.       || MARKERP (object))
  399.     return Qt;
  400.   return Qnil;
  401. }
  402.  
  403. #ifdef LISP_FLOAT_TYPE
  404. DEFUN ("floatp", Ffloatp, Sfloatp, 1, 1, 0,
  405.        "t if OBJECT is a floating point number.")
  406.   (object)
  407.      Lisp_Object object;
  408. {
  409.   if (FLOATP (object))
  410.     return Qt;
  411.   return Qnil;
  412. }
  413. #endif /* LISP_FLOAT_TYPE */
  414.  
  415. DEFUN ("type-of", Ftype_of, Stype_of, 1, 1, 0,
  416.   "Return a symbol representing the type of OBJECT.")
  417.   (object)
  418.     Lisp_Object object;
  419. {
  420.   if (CONSP (object))
  421.     return Qcons;
  422.   if (SYMBOLP (object))
  423.     return Qsymbol;
  424.   if (KEYWORDP (object))
  425.     return Qkeyword;
  426.   if (INTP (object))
  427.     return Qinteger;
  428.   if (STRINGP (object))
  429.     return Qstring;
  430.   if (VECTORP (object))
  431.     return Qvector;
  432.   assert (LRECORDP (object));
  433.   return intern (XRECORD_LHEADER (object)->implementation->name);
  434. }
  435.  
  436.  
  437. /* Extract and set components of lists */
  438.  
  439. DEFUN ("car", Fcar, Scar, 1, 1, 0,
  440.   "Return the car of CONSCELL.  If arg is nil, return nil.\n\
  441. Error if arg is not nil and not a cons cell.  See also `car-safe'.")
  442.   (conscell)
  443.      Lisp_Object conscell;
  444. {
  445.   while (1)
  446.     {
  447.       if (CONSP (conscell))
  448.     return XCAR (conscell);
  449.       else if (EQ (conscell, Qnil))
  450.     return Qnil;
  451.       else
  452.     conscell = wrong_type_argument (Qconsp, conscell);
  453.     }
  454. }
  455.  
  456. DEFUN ("car-safe", Fcar_safe, Scar_safe, 1, 1, 0,
  457.   "Return the car of OBJECT if it is a cons cell, or else nil.")
  458.   (object)
  459.      Lisp_Object object;
  460. {
  461.   if (CONSP (object))
  462.     return XCAR (object);
  463.   else
  464.     return Qnil;
  465. }
  466.  
  467. DEFUN ("cdr", Fcdr, Scdr, 1, 1, 0,
  468.   "Return the cdr of CONSCELL.  If arg is nil, return nil.\n\
  469. Error if arg is not nil and not a cons cell.  See also `cdr-safe'.")
  470.   (conscell)
  471.      Lisp_Object conscell;
  472. {
  473.   while (1)
  474.     {
  475.       if (CONSP (conscell))
  476.     return XCDR (conscell);
  477.       else if (EQ (conscell, Qnil))
  478.     return Qnil;
  479.       else
  480.     conscell = wrong_type_argument (Qconsp, conscell);
  481.     }
  482. }
  483.  
  484. DEFUN ("cdr-safe", Fcdr_safe, Scdr_safe, 1, 1, 0,
  485.   "Return the cdr of OBJECT if it is a cons cell, or else  nil.")
  486.   (object)
  487.      Lisp_Object object;
  488. {
  489.   if (CONSP (object))
  490.     return XCDR (object);
  491.   else
  492.     return Qnil;
  493. }
  494.  
  495. DEFUN ("setcar", Fsetcar, Ssetcar, 2, 2, 0,
  496.   "Set the car of CONSCELL to be NEWCAR.  Returns NEWCAR.")
  497.   (conscell, newcar)
  498.      Lisp_Object conscell, newcar;
  499. {
  500.   if (!CONSP (conscell))
  501.     conscell = wrong_type_argument (Qconsp, conscell);
  502.  
  503.   CHECK_IMPURE (conscell);
  504.   XCAR (conscell) = newcar;
  505.   return newcar;
  506. }
  507.  
  508. DEFUN ("setcdr", Fsetcdr, Ssetcdr, 2, 2, 0,
  509.   "Set the cdr of CONSCELL to be NEWCDR.  Returns NEWCDR.")
  510.   (conscell, newcdr)
  511.      Lisp_Object conscell, newcdr;
  512. {
  513.   if (!CONSP (conscell))
  514.     conscell = wrong_type_argument (Qconsp, conscell);
  515.  
  516.   CHECK_IMPURE (conscell);
  517.   XCDR (conscell) = newcdr;
  518.   return newcdr;
  519. }
  520.  
  521. /* Find the function at the end of a chain of symbol function indirections.  */
  522.  
  523. /* If OBJECT is a symbol, find the end of its function chain and
  524.    return the value found there.  If OBJECT is not a symbol, just
  525.    return it.  If there is a cycle in the function chain, signal a
  526.    cyclic-function-indirection error.
  527.  
  528.    This is like Findirect_function, except that it doesn't signal an
  529.    error if the chain ends up unbound.  */
  530. Lisp_Object
  531. indirect_function (Lisp_Object object, int errorp)
  532. {
  533.   Lisp_Object tortoise = object; 
  534.   Lisp_Object hare = object;
  535.  
  536.   for (;;)
  537.     {
  538.       if (!SYMBOLP (hare) || EQ (hare, Qunbound))
  539.     break;
  540.       hare = XSYMBOL (hare)->function;
  541.       if (!SYMBOLP (hare) || EQ (hare, Qunbound))
  542.     break;
  543.       hare = XSYMBOL (hare)->function;
  544.  
  545.       tortoise = XSYMBOL (tortoise)->function;
  546.  
  547.       if (EQ (hare, tortoise))
  548.     return (Fsignal (Qcyclic_function_indirection, list1 (object)));
  549.     }
  550.  
  551.   if (EQ (hare, Qunbound) && errorp)
  552.     return Fsignal (Qvoid_function, list1 (object));
  553.   return hare;
  554. }
  555.  
  556. DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
  557.   "Return the function at the end of OBJECT's function chain.\n\
  558. If OBJECT is a symbol, follow all function indirections and return\n\
  559. the final function binding.\n\
  560. If OBJECT is not a symbol, just return it.\n\
  561. Signal a void-function error if the final symbol is unbound.\n\
  562. Signal a cyclic-function-indirection error if there is a loop in the\n\
  563. function chain of symbols.")
  564.   (object)
  565.     Lisp_Object object;
  566. {
  567.   return indirect_function (object, 1);
  568. }
  569.  
  570. /* Extract and set vector and string elements */
  571.  
  572. DEFUN ("aref", Faref, Saref, 2, 2, 0,
  573.   "Return the element of ARRAY at index INDEX.\n\
  574. ARRAY may be a vector or a string, or a byte-code object.  INDEX starts at 0.")
  575.   (array, index)
  576.      Lisp_Object array;
  577.      Lisp_Object index;
  578. {
  579.   int idxval;
  580.  
  581.  retry:
  582.   CHECK_INT (index, 1);
  583.   idxval = XINT (index);
  584.   if (idxval < 0)
  585.     {
  586.     lose:
  587.       args_out_of_range (array, index);
  588.     }
  589.   if (VECTORP (array))
  590.     {
  591.       if (idxval >= vector_length (XVECTOR (array))) goto lose;
  592.       return vector_data (XVECTOR (array))[idxval];
  593.     }
  594.   else if (STRINGP (array))
  595.     {
  596.       if (idxval >= string_char_length (XSTRING (array))) goto lose;
  597.       return (make_number (string_char (XSTRING (array), idxval)));
  598.     }
  599.   else if (BYTECODEP (array))
  600.     {
  601.       /* Weird, gross compatibility kludge */
  602.       return (Felt (array, index));
  603.     }
  604.   else
  605.     {
  606.       array = wrong_type_argument (Qarrayp, array);
  607.       goto retry;
  608.     }
  609. }
  610.  
  611. DEFUN ("aset", Faset, Saset, 3, 3, 0,
  612.   "Store into the element of ARRAY at index IDX the value NEWVAL.\n\
  613. ARRAY may be a vector or a string.  IDX starts at 0.")
  614.   (array, idx, newval)
  615.      Lisp_Object array;
  616.      Lisp_Object idx, newval;
  617. {
  618.   int idxval;
  619.  
  620.   CHECK_INT (idx, 1);
  621.   if (!VECTORP (array) && !STRINGP (array))
  622.     array = wrong_type_argument (Qarrayp, array);
  623.  
  624.   idxval = XINT (idx);
  625.   if (idxval < 0)
  626.     {
  627.     lose:
  628.       args_out_of_range (array, idx);
  629.     }
  630.   CHECK_IMPURE (array);
  631.  
  632.   if (VECTORP (array))
  633.     {
  634.       if (idxval >= vector_length (XVECTOR (array))) goto lose;
  635.       vector_data (XVECTOR (array))[idxval] = newval;
  636.     }
  637.   else                          /* string */
  638.     {
  639.       CHECK_COERCE_CHAR (newval, 2);
  640.       if (idxval >= string_char_length (XSTRING (array))) goto lose;
  641.       set_string_char (XSTRING (array), idxval, XINT (newval));
  642.       bump_string_modiff (array);
  643.     }
  644.  
  645.   return newval;
  646. }
  647.  
  648.  
  649. /* Function objects */
  650.  
  651. /* The bytecode->doc_and_interactive slot uses the minimal number of conses,
  652.    based on bytecode->flags; it may take any of the following forms:
  653.     doc
  654.     interactive
  655.     domain
  656.     (doc . interactive)
  657.     (doc . domain)
  658.     (interactive . domain)
  659.     (doc . (interactive . domain))
  660.  */
  661.  
  662. /* Caller must check flags.interactivep first */
  663. Lisp_Object
  664. bytecode_interactive (struct Lisp_Bytecode *b)
  665. {
  666.   assert (b->flags.interactivep);
  667.   if (b->flags.documentationp && b->flags.domainp)
  668.     return (XCAR (XCDR (b->doc_and_interactive)));
  669.   else if (b->flags.documentationp)
  670.     return (XCDR (b->doc_and_interactive));
  671.   else if (b->flags.domainp)
  672.     return (XCAR (b->doc_and_interactive));
  673.  
  674.   /* if all else fails... */
  675.   return (b->doc_and_interactive);
  676. }
  677.  
  678. /* Caller need not check flags.documentationp first */
  679. Lisp_Object
  680. bytecode_documentation (struct Lisp_Bytecode *b)
  681. {
  682.   if (! b->flags.documentationp)
  683.     return Qnil;
  684.   else if (b->flags.interactivep && b->flags.domainp)
  685.     return (XCAR (b->doc_and_interactive));
  686.   else if (b->flags.interactivep)
  687.     return (XCAR (b->doc_and_interactive));
  688.   else if (b->flags.domainp)
  689.     return (XCAR (b->doc_and_interactive));
  690.   else
  691.     return (b->doc_and_interactive);
  692. }
  693.  
  694. /* Caller need not check flags.domainp first */
  695. Lisp_Object
  696. bytecode_domain (struct Lisp_Bytecode *b)
  697. {
  698.   if (! b->flags.domainp)
  699.     return Qnil;
  700.   else if (b->flags.documentationp && b->flags.interactivep)
  701.     return (XCDR (XCDR (b->doc_and_interactive)));
  702.   else if (b->flags.documentationp)
  703.     return (XCDR (b->doc_and_interactive));
  704.   else if (b->flags.interactivep)
  705.     return (XCDR (b->doc_and_interactive));
  706.   else
  707.     return (b->doc_and_interactive);
  708. }
  709.  
  710. /* used only by Snarf-documentation; there must be doc already. */
  711. void
  712. set_bytecode_documentation (struct Lisp_Bytecode *b, Lisp_Object new)
  713. {
  714.   assert (b->flags.documentationp);
  715.   assert (INTP (new) || STRINGP (new));
  716.  
  717.   if (b->flags.interactivep && b->flags.domainp)
  718.     XCAR (b->doc_and_interactive) = new;
  719.   else if (b->flags.interactivep)
  720.     XCAR (b->doc_and_interactive) = new;
  721.   else if (b->flags.domainp)
  722.     XCAR (b->doc_and_interactive) = new;
  723.   else
  724.     b->doc_and_interactive = new;
  725. }
  726.  
  727. DEFUN ("compiled-function-instructions", Fcompiled_function_instructions,
  728.        Scompiled_function_instructions, 1, 1, 0,
  729.        "Return the byte-opcode string of the compiled-function object.")
  730.      (function)
  731.      Lisp_Object function;
  732. {
  733.   CHECK_BYTECODE (function, 0);
  734.   return (XBYTECODE (function)->bytecodes);
  735. }
  736.  
  737. DEFUN ("compiled-function-constants", Fcompiled_function_constants,
  738.        Scompiled_function_constants, 1, 1, 0,
  739.        "Return the constants vector of the compiled-function object.")
  740.      (function)
  741.      Lisp_Object function;
  742. {
  743.   CHECK_BYTECODE (function, 0);
  744.   return (XBYTECODE (function)->constants);
  745. }
  746.  
  747. DEFUN ("compiled-function-stack-depth", Fcompiled_function_stack_depth,
  748.        Scompiled_function_stack_depth, 1, 1, 0,
  749.        "Return the max stack depth of the compiled-function object.")
  750.      (function)
  751.      Lisp_Object function;
  752. {
  753.   CHECK_BYTECODE (function, 0);
  754.   return (make_number (XBYTECODE (function)->maxdepth));
  755. }
  756.  
  757. DEFUN ("compiled-function-arglist", Fcompiled_function_arglist,
  758.        Scompiled_function_arglist, 1, 1, 0,
  759.        "Return the argument list of the compiled-function object.")
  760.      (function)
  761.      Lisp_Object function;
  762. {
  763.   CHECK_BYTECODE (function, 0);
  764.   return (XBYTECODE (function)->arglist);
  765. }
  766.  
  767. DEFUN ("compiled-function-interactive", Fcompiled_function_interactive,
  768.        Scompiled_function_interactive, 1, 1, 0,
  769.        "Return the interactive spec of the compiled-function object, or nil.")
  770.      (function)
  771.      Lisp_Object function;
  772. {
  773.   CHECK_BYTECODE (function, 0);
  774.   if (!XBYTECODE (function)->flags.interactivep)
  775.     return Qnil;
  776.   return (list2 (Qinteractive, bytecode_interactive (XBYTECODE (function))));
  777. }
  778.  
  779. DEFUN ("compiled-function-domain", Fcompiled_function_domain,
  780.        Scompiled_function_domain, 1, 1, 0,
  781.        "Return the domain of the compiled-function object, or nil.\n\
  782. This is only meaningful if I18N3 was enabled when emacs was compiled.")
  783.      (function)
  784.      Lisp_Object function;
  785. {
  786.   CHECK_BYTECODE (function, 0);
  787.   if (!XBYTECODE (function)->flags.domainp)
  788.     return Qnil;
  789.   return (bytecode_domain (XBYTECODE (function)));
  790. }
  791.  
  792.  
  793. /* Arithmetic functions */
  794.  
  795. enum comparison { equal, notequal, less, grtr, less_or_equal, grtr_or_equal };
  796.  
  797. static Lisp_Object
  798. arithcompare (Lisp_Object num1, Lisp_Object num2, 
  799.               enum comparison comparison)
  800. {
  801.   int floatp = 0;
  802.  
  803.   CHECK_INT_OR_FLOAT_COERCE_MARKER (num1, 0);
  804.   CHECK_INT_OR_FLOAT_COERCE_MARKER (num2, 0);
  805.  
  806. #ifdef LISP_FLOAT_TYPE
  807.   if (FLOATP (num1) || FLOATP (num2))
  808.     {
  809.       double f1, f2;
  810.  
  811.       floatp = 1;
  812.       f1 = (FLOATP (num1)) ? float_data (XFLOAT (num1)) : XINT (num1);
  813.       f2 = (FLOATP (num2)) ? float_data (XFLOAT (num2)) : XINT (num2);
  814.  
  815.       switch (comparison)
  816.         {
  817.         case equal:
  818.           if (f1 == f2)
  819.             return Qt;
  820.           return Qnil;
  821.  
  822.         case notequal:
  823.           if (f1 != f2)
  824.             return Qt;
  825.           return Qnil;
  826.  
  827.         case less:
  828.           if (f1 < f2)
  829.             return Qt;
  830.           return Qnil;
  831.  
  832.         case less_or_equal:
  833.           if (f1 <= f2)
  834.             return Qt;
  835.           return Qnil;
  836.  
  837.         case grtr:
  838.           if (f1 > f2)
  839.             return Qt;
  840.           return Qnil;
  841.  
  842.         case grtr_or_equal:
  843.           if (f1 >= f2)
  844.             return Qt;
  845.           return Qnil;
  846.         }
  847.     }
  848. #endif /* LISP_FLOAT_TYPE */
  849.   else
  850.     {
  851.       switch (comparison)
  852.         {
  853.         case equal:
  854.           if (XINT (num1) == XINT (num2))
  855.             return Qt;
  856.           return Qnil;
  857.  
  858.         case notequal:
  859.           if (XINT (num1) != XINT (num2))
  860.             return Qt;
  861.           return Qnil;
  862.  
  863.         case less:
  864.           if (XINT (num1) < XINT (num2))
  865.             return Qt;
  866.           return Qnil;
  867.  
  868.         case less_or_equal:
  869.           if (XINT (num1) <= XINT (num2))
  870.             return Qt;
  871.           return Qnil;
  872.  
  873.         case grtr:
  874.           if (XINT (num1) > XINT (num2))
  875.             return Qt;
  876.           return Qnil;
  877.  
  878.         case grtr_or_equal:
  879.           if (XINT (num1) >= XINT (num2))
  880.             return Qt;
  881.           return Qnil;
  882.         }
  883.     }
  884.   abort ();
  885.   return Qnil;    /* suppress compiler warning */
  886. }
  887.  
  888. DEFUN ("=", Feqlsign, Seqlsign, 2, 2, 0,
  889.   "T if two args, both numbers or markers, are equal.")
  890.   (num1, num2)
  891.      Lisp_Object num1, num2;
  892. {
  893.   return arithcompare (num1, num2, equal);
  894. }
  895.  
  896. DEFUN ("<", Flss, Slss, 2, 2, 0,
  897.   "T if first arg is less than second arg.  Both must be numbers or markers.")
  898.   (num1, num2)
  899.      Lisp_Object num1, num2;
  900. {
  901.   return arithcompare (num1, num2, less);
  902. }
  903.  
  904. DEFUN (">", Fgtr, Sgtr, 2, 2, 0,
  905.   "T if first arg is greater than second arg.  Both must be numbers or markers.")
  906.   (num1, num2)
  907.      Lisp_Object num1, num2;
  908. {
  909.   return arithcompare (num1, num2, grtr);
  910. }
  911.  
  912. DEFUN ("<=", Fleq, Sleq, 2, 2, 0,
  913.   "T if first arg is less than or equal to second arg.\n\
  914. Both must be numbers or markers.")
  915.   (num1, num2)
  916.      Lisp_Object num1, num2;
  917. {
  918.   return arithcompare (num1, num2, less_or_equal);
  919. }
  920.  
  921. DEFUN (">=", Fgeq, Sgeq, 2, 2, 0,
  922.   "T if first arg is greater than or equal to second arg.\n\
  923. Both must be numbers or markers.")
  924.   (num1, num2)
  925.      Lisp_Object num1, num2;
  926. {
  927.   return arithcompare (num1, num2, grtr_or_equal);
  928. }
  929.  
  930. DEFUN ("/=", Fneq, Sneq, 2, 2, 0,
  931.   "T if first arg is not equal to second arg.  Both must be numbers or markers.")
  932.   (num1, num2)
  933.      Lisp_Object num1, num2;
  934. {
  935.   return arithcompare (num1, num2, notequal);
  936. }
  937.  
  938. DEFUN ("zerop", Fzerop, Szerop, 1, 1, 0, "T if NUMBER is zero.")
  939.   (number)
  940.      Lisp_Object number;
  941. {
  942.   CHECK_INT_OR_FLOAT (number, 0);
  943.  
  944. #ifdef LISP_FLOAT_TYPE
  945.   if (FLOATP (number))
  946.     {
  947.       if (float_data (XFLOAT (number)) == 0.0)
  948.     return Qt;
  949.       return Qnil;
  950.     }
  951. #endif /* LISP_FLOAT_TYPE */
  952.  
  953.   if (XINT (number) == 0)
  954.     return Qt;
  955.   return Qnil;
  956. }
  957.  
  958. /* Convert between a 32-bit value and a cons of two 16-bit values.
  959.    This is used to pass 32-bit integers to and from the user.
  960.    Use time_to_lisp() and lisp_to_time() for time values.
  961.  
  962.    If you're thinking of using this to store a pointer into a Lisp Object
  963.    for internal purposes (such as when calling record_unwind_protect()),
  964.    try using make_opaque_ptr()/get_opaque_ptr() instead. */
  965. Lisp_Object
  966. word_to_lisp (unsigned int item)
  967. {
  968.   return Fcons (make_number (item >> 16), make_number (item & 0xffff));
  969. }
  970.  
  971. unsigned int
  972. lisp_to_word (Lisp_Object item)
  973. {
  974.   if (INTP (item))
  975.     return XINT (item);
  976.   else
  977.     {
  978.       Lisp_Object top = Fcar (item);
  979.       Lisp_Object bot = Fcdr (item);
  980.       CHECK_INT (top, 0);
  981.       CHECK_INT (bot, 0);
  982.       return (XINT (top) << 16) | (XINT (bot) & 0xffff);
  983.     }
  984. }
  985.  
  986.  
  987. DEFUN ("number-to-string", Fnumber_to_string, Snumber_to_string, 1, 1, 0,
  988.   "Convert NUM to a string by printing it in decimal.\n\
  989. Uses a minus sign if negative.\n\
  990. NUM may be an integer or a floating point number.")
  991.   (num)
  992.      Lisp_Object num;
  993. {
  994.   char buffer[20];
  995.  
  996.   CHECK_INT_OR_FLOAT (num, 0);
  997.  
  998. #ifdef LISP_FLOAT_TYPE
  999.   if (FLOATP (num))
  1000.     {
  1001.       char pigbuf[350];    /* see comments in float_to_string */
  1002.  
  1003.       float_to_string (pigbuf, float_data (XFLOAT (num)));
  1004.       return build_string (pigbuf);      
  1005.     }
  1006. #endif /* LISP_FLOAT_TYPE */
  1007.  
  1008.   sprintf (buffer, "%d", XINT (num));
  1009.   return build_string (buffer);
  1010. }
  1011.  
  1012. DEFUN ("string-to-number", Fstring_to_number, Sstring_to_number, 1, 1, 0,
  1013.   "Convert STRING to a number by parsing it as a decimal number.\n\
  1014. This parses both integers and floating point numbers.\n\
  1015. It ignores leading spaces and tabs.")
  1016.   (string)
  1017.      Lisp_Object string;
  1018. {
  1019.   char *p;
  1020.   CHECK_STRING (string, 0);
  1021.  
  1022.   p = (char *) string_data (XSTRING (string));
  1023.   /* Skip any whitespace at the front of the number.  Some versions of
  1024.      atoi do this anyway, so we might as well make Emacs lisp consistent.  */
  1025.   while (*p == ' ' || *p == '\t')
  1026.     p++;
  1027.  
  1028. #ifdef LISP_FLOAT_TYPE
  1029.   if (isfloat_string (p))
  1030.     return make_float (atof (p));
  1031. #endif /* LISP_FLOAT_TYPE */
  1032.  
  1033.   return make_number (atoi (p));
  1034. }
  1035.   
  1036. enum arithop
  1037.   { Aadd, Asub, Amult, Adiv, Alogand, Alogior, Alogxor, Amax, Amin };
  1038.  
  1039. #ifdef LISP_FLOAT_TYPE
  1040. static Lisp_Object float_arith_driver (double accum, int argnum, 
  1041.                                        enum arithop code, 
  1042.                                        int nargs, Lisp_Object *args);
  1043. #endif
  1044.  
  1045.  
  1046. static Lisp_Object
  1047. arith_driver (enum arithop code, int nargs, Lisp_Object *args)
  1048. {
  1049.   Lisp_Object val;
  1050.   REGISTER int argnum;
  1051.   REGISTER LISP_WORD_TYPE accum = 0;
  1052.   REGISTER LISP_WORD_TYPE next;
  1053.  
  1054.   switch (code)
  1055.     {
  1056.     case Alogior:
  1057.     case Alogxor:
  1058.     case Aadd:
  1059.     case Asub:
  1060.       accum = 0; break;
  1061.     case Amult:
  1062.       accum = 1; break;
  1063.     case Alogand:
  1064.       accum = -1; break;
  1065.     case Adiv:
  1066.     case Amax:
  1067.     case Amin:
  1068.       accum = 0;
  1069.       break;
  1070.     default:
  1071.       abort ();
  1072.     }
  1073.  
  1074.   for (argnum = 0; argnum < nargs; argnum++)
  1075.     {
  1076.       val = args[argnum];    /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
  1077.       CHECK_INT_OR_FLOAT_COERCE_MARKER (val, argnum);
  1078.  
  1079. #ifdef LISP_FLOAT_TYPE
  1080.       if (FLOATP (val)) /* time to do serious math */
  1081.     return (float_arith_driver ((double) accum, argnum, code,
  1082.                     nargs, args));
  1083. #endif /* LISP_FLOAT_TYPE */
  1084.       args[argnum] = val;    /* runs into a compiler bug. */
  1085.       next = XINT (args[argnum]);
  1086.       switch (code)
  1087.     {
  1088.     case Aadd: accum += next; break;
  1089.     case Asub:
  1090.       if (!argnum && nargs != 1)
  1091.         next = - next;
  1092.       accum -= next;
  1093.       break;
  1094.     case Amult: accum *= next; break;
  1095.     case Adiv:
  1096.       if (!argnum) accum = next;
  1097.       else
  1098.         {
  1099.           if (next == 0)
  1100.         Fsignal (Qarith_error, Qnil);
  1101.           accum /= next;
  1102.         }
  1103.       break;
  1104.     case Alogand: accum &= next; break;
  1105.     case Alogior: accum |= next; break;
  1106.     case Alogxor: accum ^= next; break;
  1107.     case Amax: if (!argnum || next > accum) accum = next; break;
  1108.     case Amin: if (!argnum || next < accum) accum = next; break;
  1109.     }
  1110.     }
  1111.  
  1112.   XSETINT (val, accum);
  1113.   return val;
  1114. }
  1115.  
  1116. #ifdef LISP_FLOAT_TYPE
  1117. static Lisp_Object
  1118. float_arith_driver (double accum, int argnum, enum arithop code, int nargs,
  1119.             Lisp_Object *args)
  1120. {
  1121.   REGISTER Lisp_Object val;
  1122.   double next;
  1123.   
  1124.   for (; argnum < nargs; argnum++)
  1125.     {
  1126.       val = args[argnum];    /* using args[argnum] as argument to CHECK_INT_OR_FLOAT_... */
  1127.       CHECK_INT_OR_FLOAT_COERCE_MARKER (val, argnum);
  1128.  
  1129.       if (FLOATP (val))
  1130.     {
  1131.       next = float_data (XFLOAT (val));
  1132.     }
  1133.       else
  1134.     {
  1135.       args[argnum] = val;    /* runs into a compiler bug. */
  1136.       next = XINT (args[argnum]);
  1137.     }
  1138.       switch (code)
  1139.     {
  1140.     case Aadd:
  1141.       accum += next;
  1142.       break;
  1143.     case Asub:
  1144.       if (!argnum && nargs != 1)
  1145.         next = - next;
  1146.       accum -= next;
  1147.       break;
  1148.     case Amult:
  1149.       accum *= next;
  1150.       break;
  1151.     case Adiv:
  1152.       if (!argnum)
  1153.         accum = next;
  1154.       else
  1155.         {
  1156.           if (next == 0)
  1157.         Fsignal (Qarith_error, Qnil);
  1158.           accum /= next;
  1159.         }
  1160.       break;
  1161.     case Alogand:
  1162.     case Alogior:
  1163.     case Alogxor:
  1164.       return wrong_type_argument (Qinteger_or_marker_p, val);
  1165.     case Amax:
  1166.       if (!argnum || isnan (next) || next > accum)
  1167.         accum = next;
  1168.       break;
  1169.     case Amin:
  1170.       if (!argnum || isnan (next) || next < accum)
  1171.         accum = next;
  1172.       break;
  1173.     }
  1174.     }
  1175.  
  1176.   return make_float (accum);
  1177. }
  1178. #endif /* LISP_FLOAT_TYPE */
  1179.  
  1180. DEFUN ("+", Fplus, Splus, 0, MANY, 0,
  1181.   "Return sum of any number of arguments, which are numbers or markers.")
  1182.   (nargs, args)
  1183.      int nargs;
  1184.      Lisp_Object *args;
  1185. {
  1186.   return arith_driver (Aadd, nargs, args);
  1187. }
  1188.  
  1189. DEFUN ("-", Fminus, Sminus, 0, MANY, 0,
  1190.   "Negate number or subtract numbers or markers.\n\
  1191. With one arg, negates it.  With more than one arg,\n\
  1192. subtracts all but the first from the first.")
  1193.   (nargs, args)
  1194.      int nargs;
  1195.      Lisp_Object *args;
  1196. {
  1197.   return arith_driver (Asub, nargs, args);
  1198. }
  1199.  
  1200. DEFUN ("*", Ftimes, Stimes, 0, MANY, 0,
  1201.   "Return product of any number of arguments, which are numbers or markers.")
  1202.   (nargs, args)
  1203.      int nargs;
  1204.      Lisp_Object *args;
  1205. {
  1206.   return arith_driver (Amult, nargs, args);
  1207. }
  1208.  
  1209. DEFUN ("/", Fquo, Squo, 2, MANY, 0,
  1210.   "Return first argument divided by all the remaining arguments.\n\
  1211. The arguments must be numbers or markers.")
  1212.   (nargs, args)
  1213.      int nargs;
  1214.      Lisp_Object *args;
  1215. {
  1216.   return arith_driver (Adiv, nargs, args);
  1217. }
  1218.  
  1219. DEFUN ("%", Frem, Srem, 2, 2, 0,
  1220.   "Return remainder of first arg divided by second.\n\
  1221. Both must be integers or markers.")
  1222.   (num1, num2)
  1223.      Lisp_Object num1, num2;
  1224. {
  1225.   CHECK_INT_COERCE_MARKER (num1, 0);
  1226.   CHECK_INT_COERCE_MARKER (num2, 1);
  1227.  
  1228.   if (EQ (num2, Qzero))
  1229.     Fsignal (Qarith_error, Qnil);
  1230.  
  1231.   return (make_number (XINT (num1) % XINT (num2)));
  1232. }
  1233.  
  1234. DEFUN ("mod", Fmod, Smod, 2, 2, 0,
  1235.   "Return X modulo Y.\n\
  1236. The result falls between zero (inclusive) and Y (exclusive).\n\
  1237. Both X and Y must be numbers or markers.\n\
  1238. If either argument is a float, a float will be returned.")
  1239.   (x, y)
  1240.      Lisp_Object x, y;
  1241. {
  1242.   int i1, i2;
  1243.  
  1244.   CHECK_INT_OR_FLOAT_COERCE_MARKER (x, 0);
  1245.   CHECK_INT_OR_FLOAT_COERCE_MARKER (y, 1);
  1246.  
  1247. #ifdef LISP_FLOAT_TYPE
  1248.   if (FLOATP (x) || FLOATP (y))
  1249.     {
  1250.       double f1, f2;
  1251.  
  1252.       f1 = ((FLOATP (x)) ? float_data (XFLOAT (x)) : XINT (x));
  1253.       f2 = ((FLOATP (y)) ? float_data (XFLOAT (y)) : XINT (y));
  1254.       if (f2 == 0)
  1255.     Fsignal (Qarith_error, Qnil);
  1256.  
  1257.       /* Note, ANSI *requires* the presence of the fmod() library routine.
  1258.          If your system doesn't have it, complain to your vendor, because
  1259.          that is a bug. */
  1260. #ifdef USE_DREM                 /* #### obsolete?? */
  1261.       /* drem returns a result in the range [-f2/2,f2/2] instead of
  1262.          [0,f2), but the sign fixup below takes care of that. */
  1263.       f1 = drem (f1, f2);
  1264. #else
  1265.       f1 = fmod (f1, f2); /* fmod is ANSI. */
  1266. #endif
  1267.  
  1268.       /* If the "remainder" comes out with the wrong sign, fix it.  */
  1269.       if ((f1 < 0) != (f2 < 0))
  1270.     f1 += f2;
  1271.       return (make_float (f1));
  1272.     }
  1273. #else /* not LISP_FLOAT_TYPE */
  1274.   CHECK_INT_OR_FLOAT_COERCE_MARKER (x, 0);
  1275.   CHECK_INT_OR_FLOAT_COERCE_MARKER (y, 1);
  1276. #endif /* not LISP_FLOAT_TYPE */
  1277.  
  1278.   i1 = XINT (x);
  1279.   i2 = XINT (y);
  1280.  
  1281.   if (i2 == 0)
  1282.     Fsignal (Qarith_error, Qnil);
  1283.   
  1284.   i1 %= i2;
  1285.  
  1286.   /* If the "remainder" comes out with the wrong sign, fix it.  */
  1287.   if ((i1 < 0) != (i2 < 0))
  1288.     i1 += i2;
  1289.  
  1290.   return (make_number (i1));
  1291. }
  1292.  
  1293.  
  1294. DEFUN ("max", Fmax, Smax, 1, MANY, 0,
  1295.   "Return largest of all the arguments (which must be numbers or markers).\n\
  1296. The value is always a number; markers are converted to numbers.")
  1297.   (nargs, args)
  1298.      int nargs;
  1299.      Lisp_Object *args;
  1300. {
  1301.   return arith_driver (Amax, nargs, args);
  1302. }
  1303.  
  1304. DEFUN ("min", Fmin, Smin, 1, MANY, 0,
  1305.   "Return smallest of all the arguments (which must be numbers or markers).\n\
  1306. The value is always a number; markers are converted to numbers.")
  1307.   (nargs, args)
  1308.      int nargs;
  1309.      Lisp_Object *args;
  1310. {
  1311.   return arith_driver (Amin, nargs, args);
  1312. }
  1313.  
  1314. DEFUN ("logand", Flogand, Slogand, 0, MANY, 0,
  1315.   "Return bitwise-and of all the arguments.\n\
  1316. Arguments may be integers, or markers converted to integers.")
  1317.   (nargs, args)
  1318.      int nargs;
  1319.      Lisp_Object *args;
  1320. {
  1321.   return arith_driver (Alogand, nargs, args);
  1322. }
  1323.  
  1324. DEFUN ("logior", Flogior, Slogior, 0, MANY, 0,
  1325.   "Return bitwise-or of all the arguments.\n\
  1326. Arguments may be integers, or markers converted to integers.")
  1327.   (nargs, args)
  1328.      int nargs;
  1329.      Lisp_Object *args;
  1330. {
  1331.   return arith_driver (Alogior, nargs, args);
  1332. }
  1333.  
  1334. DEFUN ("logxor", Flogxor, Slogxor, 0, MANY, 0,
  1335.   "Return bitwise-exclusive-or of all the arguments.\n\
  1336. Arguments may be integers, or markers converted to integers.")
  1337.   (nargs, args)
  1338.      int nargs;
  1339.      Lisp_Object *args;
  1340. {
  1341.   return arith_driver (Alogxor, nargs, args);
  1342. }
  1343.  
  1344. DEFUN ("ash", Fash, Sash, 2, 2, 0,
  1345.   "Return VALUE with its bits shifted left by COUNT.\n\
  1346. If COUNT is negative, shifting is actually to the right.\n\
  1347. In this case, the sign bit is duplicated.")
  1348.   (value, count)
  1349.      Lisp_Object value, count;
  1350. {
  1351.   CHECK_INT (value, 0);
  1352.   CHECK_INT (count, 1);
  1353.  
  1354.   if (XINT (count) > 0)
  1355.     return (make_number (XINT (value) << XINT (count)));
  1356.   else
  1357.     return (make_number (XINT (value) >> -XINT (count)));
  1358. }
  1359.  
  1360. DEFUN ("lsh", Flsh, Slsh, 2, 2, 0,
  1361.   "Return VALUE with its bits shifted left by COUNT.\n\
  1362. If COUNT is negative, shifting is actually to the right.\n\
  1363. In this case,  zeros are shifted in on the left.")
  1364.   (value, count)
  1365.      Lisp_Object value, count;
  1366. {
  1367.   Lisp_Object val;
  1368.  
  1369.   CHECK_INT (value, 0);
  1370.   CHECK_INT (count, 1);
  1371.  
  1372.   if (XINT (count) > 0)
  1373.     XSETINT (val, XUINT (value) << XINT (count));
  1374.   else
  1375.     XSETINT (val, XUINT (value) >> -XINT (count));
  1376.   return val;
  1377. }
  1378.  
  1379. DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0,
  1380.   "Return NUMBER plus one.  NUMBER may be a number or a marker.\n\
  1381. Markers are converted to integers.")
  1382.   (number)
  1383.      Lisp_Object number;
  1384. {
  1385.   CHECK_INT_OR_FLOAT_COERCE_MARKER (number, 0);
  1386.  
  1387. #ifdef LISP_FLOAT_TYPE
  1388.   if (FLOATP (number))
  1389.     return (make_float (1.0 + float_data (XFLOAT (number))));
  1390. #endif /* LISP_FLOAT_TYPE */
  1391.  
  1392.   return (make_number (XINT (number) + 1));
  1393. }
  1394.  
  1395. DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0,
  1396.   "Return NUMBER minus one.  NUMBER may be a number or a marker.\n\
  1397. Markers are converted to integers.")
  1398.   (number)
  1399.      Lisp_Object number;
  1400. {
  1401.   CHECK_INT_OR_FLOAT_COERCE_MARKER (number, 0);
  1402.  
  1403. #ifdef LISP_FLOAT_TYPE
  1404.   if (FLOATP (number))
  1405.     return (make_float (-1.0 + (float_data (XFLOAT (number)))));
  1406. #endif /* LISP_FLOAT_TYPE */
  1407.  
  1408.   return (make_number (XINT (number) - 1));
  1409. }
  1410.  
  1411. DEFUN ("lognot", Flognot, Slognot, 1, 1, 0,
  1412.   "Return the bitwise complement of NUMBER.  NUMBER must be an integer.")
  1413.   (number)
  1414.      Lisp_Object number;
  1415. {
  1416.   CHECK_INT (number, 0);
  1417.   return (make_number (~XINT (number)));
  1418. }
  1419.  
  1420. #ifdef ERROR_CHECK_TYPECHECK
  1421.  
  1422. struct Lisp_Cons *
  1423. error_check_cons (Lisp_Object a)
  1424. {
  1425.   XUNMARK (a);
  1426.   assert (CONSP (a));
  1427.   return (struct Lisp_Cons *) XPNTR (a);
  1428. }
  1429.  
  1430. struct Lisp_Vector *
  1431. error_check_vector (Lisp_Object a)
  1432. {
  1433.   XUNMARK (a);
  1434.   assert (VECTORP (a) || MARKED_RECORD_P (a));
  1435.   return (struct Lisp_Vector *) XPNTR (a);
  1436. }
  1437.  
  1438. struct Lisp_String *
  1439. error_check_string (Lisp_Object a)
  1440. {
  1441.   XUNMARK (a);
  1442.   assert (STRINGP (a));
  1443.   return (struct Lisp_String *) XPNTR (a);
  1444. }
  1445.  
  1446. #endif /* ERROR_CHECK_TYPECHECK */
  1447.  
  1448.  
  1449. /************************************************************************/
  1450. /*                            initialization                            */
  1451. /************************************************************************/
  1452.  
  1453. static SIGTYPE
  1454. arith_error (int signo)
  1455. {
  1456.   EMACS_REESTABLISH_SIGNAL (signo, arith_error);
  1457.   EMACS_UNBLOCK_SIGNAL (signo);
  1458.   signal_error (Qarith_error, Qnil);
  1459. }
  1460.  
  1461. void
  1462. init_data_very_early (void)
  1463. {
  1464.   /* Don't do this if just dumping out.
  1465.      We don't want to call `signal' in this case
  1466.      so that we don't have trouble with dumping
  1467.      signal-delivering routines in an inconsistent state.  */
  1468. #ifndef CANNOT_DUMP
  1469.   if (!initialized)
  1470.     return;
  1471. #endif /* CANNOT_DUMP */
  1472.   signal (SIGFPE, arith_error);
  1473. #ifdef uts
  1474.   signal (SIGEMT, arith_error);
  1475. #endif /* uts */
  1476. }
  1477.  
  1478. void
  1479. init_errors_once_early (void)
  1480. {
  1481.   defsymbol (&Qerror_conditions, "error-conditions");
  1482.   defsymbol (&Qerror_message, "error-message");
  1483.  
  1484.   /* We declare the errors here because some other deferrors depend
  1485.      on some of the errors below. */
  1486.  
  1487.   /* ERROR is used as a signaler for random errors for which nothing
  1488.      else is right */
  1489.  
  1490.   deferror (&Qerror, "error", "error", 0);
  1491.   deferror (&Qquit, "quit", "Quit", 0);
  1492.  
  1493.   deferror (&Qwrong_type_argument, "wrong-type-argument",
  1494.         "Wrong type argument", 1);
  1495.   deferror (&Qargs_out_of_range, "args-out-of-range", "Args out of range", 1);
  1496.   deferror (&Qvoid_function, "void-function",
  1497.         "Symbol's function definition is void", 1);
  1498.   deferror (&Qcyclic_function_indirection, "cyclic-function-indirection",
  1499.         "Symbol's chain of function indirections contains a loop", 1);
  1500.   deferror (&Qvoid_variable, "void-variable",
  1501.         "Symbol's value as variable is void", 1);
  1502.   deferror (&Qcyclic_variable_indirection, "cyclic-variable-indirection",
  1503.         "Symbol's chain of variable indirections contains a loop", 1);
  1504.   deferror (&Qsetting_constant, "setting-constant",
  1505.         "Attempt to set a constant symbol", 1);
  1506.   deferror (&Qinvalid_read_syntax, "invalid-read-syntax",
  1507.         "Invalid read syntax", 1);
  1508.  
  1509.   deferror (&Qinvalid_function, "invalid-function", "Invalid function", 1);
  1510.   deferror (&Qwrong_number_of_arguments, "wrong-number-of-arguments",
  1511.         "Wrong number of arguments", 1);
  1512.   deferror (&Qno_catch, "no-catch", "No catch for tag", 1);
  1513.   deferror (&Qend_of_file, "end-of-file", "End of file during parsing", 1);
  1514.   deferror (&Qarith_error, "arith-error", "Arithmetic error", 1);
  1515.   deferror (&Qrange_error, "range-error", "Arithmetic range error", 2);
  1516.   deferror (&Qdomain_error, "domain-error", "Arithmetic domain error", 2);
  1517.   deferror (&Qsingularity_error, "singularity-error",
  1518.         "Arithmetic singularity error", 3);
  1519.   deferror (&Qoverflow_error, "overflow-error",
  1520.         "Arithmetic overflow error", 3);
  1521.   deferror (&Qunderflow_error, "underflow-error",
  1522.         "Arithmetic underflow error", 3);
  1523.   deferror (&Qbeginning_of_buffer, "beginning-of-buffer",
  1524.         "Beginning of buffer", 1);
  1525.   deferror (&Qend_of_buffer, "end-of-buffer", "End of buffer", 1);
  1526.   deferror (&Qbuffer_read_only, "buffer-read-only", "Buffer is read-only", 1);
  1527. }
  1528.  
  1529. void
  1530. syms_of_data (void)
  1531. {
  1532.   defsymbol (&Qcons, "cons");
  1533.   defsymbol (&Qkeyword, "keyword");
  1534.   /* Qstring, Qinteger, Qsymbol, Qvector defined in general.c */
  1535.  
  1536.   defsymbol (&Qquote, "quote");
  1537.   defsymbol (&Qlambda, "lambda");
  1538.   defsymbol (&Qfunction, "function");
  1539.   defsymbol (&Qsignal, "signal");
  1540.   defsymbol (&Qtop_level, "top-level");
  1541.   defsymbol (&Qignore, "ignore");
  1542.  
  1543.   defsymbol (&Qlistp, "listp");
  1544.   defsymbol (&Qconsp, "consp");
  1545.   defsymbol (&Qsubrp, "subrp");
  1546.   defsymbol (&Qsymbolp, "symbolp");
  1547.   defsymbol (&Qkeywordp, "keywordp");
  1548.   defsymbol (&Qintegerp, "integerp");
  1549.   defsymbol (&Qcharacterp, "characterp");
  1550.   defsymbol (&Qnatnump, "natnump");
  1551.   defsymbol (&Qstringp, "stringp");
  1552.   defsymbol (&Qarrayp, "arrayp");
  1553.   defsymbol (&Qsequencep, "sequencep");
  1554.   defsymbol (&Qbufferp, "bufferp");
  1555.   defsymbol (&Qvectorp, "vectorp");
  1556.   defsymbol (&Qbytecodep, "bytecodep");
  1557.   defsymbol (&Qchar_or_string_p, "char-or-string-p");
  1558.   defsymbol (&Qmarkerp, "markerp");
  1559.   defsymbol (&Qinteger_or_marker_p, "integer-or-marker-p");
  1560.   defsymbol (&Qboundp, "boundp");
  1561.   defsymbol (&Qfboundp, "fboundp");
  1562.  
  1563. #ifdef LISP_FLOAT_TYPE
  1564.   defsymbol (&Qfloatp, "floatp");
  1565. #endif /* LISP_FLOAT_TYPE */
  1566.   defsymbol (&Qnumberp, "numberp");
  1567.   defsymbol (&Qnumber_or_marker_p, "number-or-marker-p");
  1568.  
  1569.   defsymbol (&Qcdr, "cdr");
  1570.  
  1571.   defsubr (&Swrong_type_argument);
  1572.  
  1573.   defsubr (&Seq);
  1574.   defsubr (&Snull);
  1575.   defsubr (&Slistp);
  1576.   defsubr (&Snlistp);
  1577.   defsubr (&Sconsp);
  1578.   defsubr (&Satom);
  1579.   defsubr (&Schar_or_string_p);
  1580.   defsubr (&Scharacterp);
  1581.   defsubr (&Sintegerp);
  1582.   defsubr (&Sinteger_or_marker_p);
  1583.   defsubr (&Snumberp);
  1584.   defsubr (&Snumber_or_marker_p);
  1585. #ifdef LISP_FLOAT_TYPE
  1586.   defsubr (&Sfloatp);
  1587. #endif /* LISP_FLOAT_TYPE */
  1588.   defsubr (&Snatnump);
  1589.   defsubr (&Ssymbolp);
  1590.   defsubr (&Skeywordp);
  1591.   defsubr (&Sstringp);
  1592.   defsubr (&Svectorp);
  1593.   defsubr (&Sarrayp);
  1594.   defsubr (&Ssequencep);
  1595.   defsubr (&Smarkerp);
  1596.   defsubr (&Ssubrp);
  1597.   defsubr (&Ssubr_min_args);
  1598.   defsubr (&Ssubr_max_args);
  1599.   defsubr (&Scompiled_function_p);
  1600.   defsubr (&Stype_of);
  1601.   defsubr (&Scar);
  1602.   defsubr (&Scdr);
  1603.   defsubr (&Scar_safe);
  1604.   defsubr (&Scdr_safe);
  1605.   defsubr (&Ssetcar);
  1606.   defsubr (&Ssetcdr);
  1607.   defsubr (&Sindirect_function);
  1608.   defsubr (&Saref);
  1609.   defsubr (&Saset);
  1610.  
  1611.   defsubr (&Scompiled_function_instructions);
  1612.   defsubr (&Scompiled_function_constants);
  1613.   defsubr (&Scompiled_function_stack_depth);
  1614.   defsubr (&Scompiled_function_arglist);
  1615.   defsubr (&Scompiled_function_interactive);
  1616.   defsubr (&Scompiled_function_domain);
  1617.  
  1618.   defsubr (&Snumber_to_string);
  1619.   defsubr (&Sstring_to_number);
  1620.   defsubr (&Seqlsign);
  1621.   defsubr (&Slss);
  1622.   defsubr (&Sgtr);
  1623.   defsubr (&Sleq);
  1624.   defsubr (&Sgeq);
  1625.   defsubr (&Sneq);
  1626.   defsubr (&Szerop);
  1627.   defsubr (&Splus);
  1628.   defsubr (&Sminus);
  1629.   defsubr (&Stimes);
  1630.   defsubr (&Squo);
  1631.   defsubr (&Srem);
  1632.   defsubr (&Smod);
  1633.   defsubr (&Smax);
  1634.   defsubr (&Smin);
  1635.   defsubr (&Slogand);
  1636.   defsubr (&Slogior);
  1637.   defsubr (&Slogxor);
  1638.   defsubr (&Slsh);
  1639.   defsubr (&Sash);
  1640.   defsubr (&Sadd1);
  1641.   defsubr (&Ssub1);
  1642.   defsubr (&Slognot);
  1643. }
  1644.