XEmacs 21.2.28 "Hermes".
[chise/xemacs-chise.git.1] / src / eval.c
index 0f07512..962fab8 100644 (file)
@@ -73,12 +73,11 @@ struct backtrace *backtrace_list;
    a SUBR with more than 8 arguments, use max_args == MANY.
    See the DEFUN macro in lisp.h)  */
 #define PRIMITIVE_FUNCALL(rv, fn, av, ac) do {                 \
-  void (*PF_fn)() = (void (*)()) (fn);                         \
+  void (*PF_fn)(void) = (void (*)(void)) fn;                   \
   Lisp_Object *PF_av = (av);                                   \
   switch (ac)                                                  \
     {                                                          \
-    default: abort();                                          \
-    case 0: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break;  \
+    default:rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 0); break;  \
     case 1: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 1); break;  \
     case 2: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 2); break;  \
     case 3: rv = PRIMITIVE_FUNCALL_1(PF_fn, PF_av, 3); break;  \
@@ -170,7 +169,7 @@ int specpdl_depth_counter;
 int max_specpdl_size;
 
 /* Depth in Lisp evaluations and function calls.  */
-int lisp_eval_depth;
+static int lisp_eval_depth;
 
 /* Maximum allowed depth in Lisp evaluations and function calls.  */
 int max_lisp_eval_depth;
@@ -295,9 +294,15 @@ print_subr (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
   write_c_string (trailer, printcharfun);
 }
 
-DEFINE_LRECORD_IMPLEMENTATION ("subr", subr,
-                               this_one_is_unmarkable, print_subr, 0, 0, 0,
-                              Lisp_Subr);
+static const struct lrecord_description subr_description[] = {
+  { XD_DOC_STRING, offsetof (Lisp_Subr, doc) },
+  { XD_END }
+};
+
+DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr,
+                                    this_one_is_unmarkable, print_subr, 0, 0, 0,
+                                    subr_description,
+                                    Lisp_Subr);
 \f
 /************************************************************************/
 /*                      Entering the debugger                          */
@@ -1004,8 +1009,6 @@ In byte compilation, `function' causes its argument to be compiled.
 static Lisp_Object
 define_function (Lisp_Object name, Lisp_Object defn)
 {
-  if (purify_flag)
-    defn = Fpurecopy (defn);
   Ffset (name, defn);
   LOADHIST_ATTACH (name);
   return name;
@@ -1078,14 +1081,7 @@ In lisp-interaction-mode defvar is treated as defconst.
       if (!NILP (args = XCDR (args)))
        {
          Lisp_Object doc = XCAR (args);
-#if 0 /* FSFmacs */
-         /* #### We should probably do this but it might be dangerous */
-         if (purify_flag)
-           doc = Fpurecopy (doc);
          Fput (sym, Qvariable_documentation, doc);
-#else
-         pure_put (sym, Qvariable_documentation, doc);
-#endif
          if (!NILP (args = XCDR (args)))
            error ("too many arguments");
        }
@@ -1093,7 +1089,7 @@ In lisp-interaction-mode defvar is treated as defconst.
 
 #ifdef I18N3
   if (!NILP (Vfile_domain))
-    pure_put (sym, Qvariable_domain, Vfile_domain);
+    Fput (sym, Qvariable_domain, Vfile_domain);
 #endif
 
   LOADHIST_ATTACH (sym);
@@ -1133,21 +1129,14 @@ Since `defconst' unconditionally assigns the variable,
   if (!NILP (args = XCDR (args)))
     {
       Lisp_Object doc = XCAR (args);
-#if 0 /* FSFmacs */
-      /* #### We should probably do this but it might be dangerous */
-      if (purify_flag)
-       doc = Fpurecopy (doc);
       Fput (sym, Qvariable_documentation, doc);
-#else
-      pure_put (sym, Qvariable_documentation, doc);
-#endif
       if (!NILP (args = XCDR (args)))
        error ("too many arguments");
     }
 
 #ifdef I18N3
   if (!NILP (Vfile_domain))
-    pure_put (sym, Qvariable_domain, Vfile_domain);
+    Fput (sym, Qvariable_domain, Vfile_domain);
 #endif
 
   LOADHIST_ATTACH (sym);
@@ -1167,7 +1156,7 @@ for the variable is `*'.
   return
     ((INTP (documentation) && XINT (documentation) < 0) ||
 
-     ((STRINGP (documentation)) &&
+     (STRINGP (documentation) &&
       (string_byte (XSTRING (documentation), 0) == '*')) ||
 
      /* If (STRING . INTEGER), a negative integer means a user variable. */
@@ -1493,7 +1482,7 @@ If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.
 static Lisp_Object
 condition_bind_unwind (Lisp_Object loser)
 {
-  struct Lisp_Cons *victim;
+  Lisp_Cons *victim;
   /* ((handler-fun . handler-args) ... other handlers) */
   Lisp_Object tem = XCAR (loser);
 
@@ -1515,7 +1504,7 @@ condition_bind_unwind (Lisp_Object loser)
 static Lisp_Object
 condition_case_unwind (Lisp_Object loser)
 {
-  struct Lisp_Cons *victim;
+  Lisp_Cons *victim;
 
   /* ((<unbound> . clauses) ... other handlers */
   victim = XCONS (XCAR (loser));
@@ -2481,47 +2470,48 @@ signal_quit (void)
 
 \f
 /* Used in core lisp functions for efficiency */
-void
+Lisp_Object
 signal_void_function_error (Lisp_Object function)
 {
-  Fsignal (Qvoid_function, list1 (function));
+  return Fsignal (Qvoid_function, list1 (function));
 }
 
-static void
+Lisp_Object
 signal_invalid_function_error (Lisp_Object function)
 {
-  Fsignal (Qinvalid_function, list1 (function));
+  return Fsignal (Qinvalid_function, list1 (function));
 }
 
-static void
+Lisp_Object
 signal_wrong_number_of_arguments_error (Lisp_Object function, int nargs)
 {
-  Fsignal (Qwrong_number_of_arguments, list2 (function, make_int (nargs)));
+  return Fsignal (Qwrong_number_of_arguments,
+                 list2 (function, make_int (nargs)));
 }
 
 /* Used in list traversal macros for efficiency. */
-void
+DOESNT_RETURN
 signal_malformed_list_error (Lisp_Object list)
 {
-  Fsignal (Qmalformed_list, list1 (list));
+  signal_error (Qmalformed_list, list1 (list));
 }
 
-void
+DOESNT_RETURN
 signal_malformed_property_list_error (Lisp_Object list)
 {
-  Fsignal (Qmalformed_property_list, list1 (list));
+  signal_error (Qmalformed_property_list, list1 (list));
 }
 
-void
+DOESNT_RETURN
 signal_circular_list_error (Lisp_Object list)
 {
-  Fsignal (Qcircular_list, list1 (list));
+  signal_error (Qcircular_list, list1 (list));
 }
 
-void
+DOESNT_RETURN
 signal_circular_property_list_error (Lisp_Object list)
 {
-  Fsignal (Qcircular_property_list, list1 (list));
+  signal_error (Qcircular_property_list, list1 (list));
 }
 \f
 /************************************************************************/
@@ -2633,7 +2623,7 @@ when reading the arguments.
     {
       Fsignal (Qwrong_type_argument,
               Fcons (Qcommandp,
-                     ((EQ (cmd, final))
+                     (EQ (cmd, final)
                        ? list1 (cmd)
                        : list2 (cmd, final))));
       return Qnil;
@@ -2751,11 +2741,10 @@ this does nothing and returns nil.
       file = Fsymbol_name (Fintern (file, Qnil));
     }
 
-  return Ffset (function,
-                Fpurecopy (Fcons (Qautoload, list4 (file,
-                                                    docstring,
-                                                    interactive,
-                                                    type))));
+  return Ffset (function, Fcons (Qautoload, list4 (file,
+                                                  docstring,
+                                                  interactive,
+                                                  type)));
 }
 
 Lisp_Object
@@ -2955,7 +2944,7 @@ Evaluate FORM and return its value.
       if (max_args == UNEVALLED) /* Optimize for the common case */
        {
          backtrace.evalargs = 0;
-         val = (((Lisp_Object (*) (Lisp_Object)) (subr_function (subr)))
+         val = (((Lisp_Object (*) (Lisp_Object)) subr_function (subr))
                 (original_args));
        }
       else if (nargs <= max_args)
@@ -3009,7 +2998,7 @@ Evaluate FORM and return its value.
          backtrace.args  = args;
          backtrace.nargs = nargs;
 
-         val = (((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr)))
+         val = (((Lisp_Object (*) (int, Lisp_Object *)) subr_function (subr))
                 (nargs, args));
 
          UNGCPRO;
@@ -3017,7 +3006,7 @@ Evaluate FORM and return its value.
       else
        {
        wrong_number_of_arguments:
-         signal_wrong_number_of_arguments_error (fun, nargs);
+         val = signal_wrong_number_of_arguments_error (original_fun, nargs);
        }
     }
   else if (COMPILED_FUNCTIONP (fun))
@@ -3105,7 +3094,7 @@ Evaluate FORM and return its value.
   else /* ! (SUBRP (fun) || COMPILED_FUNCTIONP (fun) || CONSP (fun)) */
     {
     invalid_function:
-      signal_invalid_function_error (fun);
+      val = signal_invalid_function_error (fun);
     }
 
   lisp_eval_depth--;
@@ -3180,14 +3169,15 @@ Thus, (funcall 'cons 'x 'y) returns (x . y).
       int max_args = subr->max_args;
       Lisp_Object spacious_args[SUBR_MAX_ARGS];
 
-      if (fun_nargs < subr->min_args)
-       goto wrong_number_of_arguments;
-
       if (fun_nargs == max_args) /* Optimize for the common case */
        {
        funcall_subr:
          FUNCALL_SUBR (val, subr, fun_args, max_args);
        }
+      else if (fun_nargs < subr->min_args)
+       {
+         goto wrong_number_of_arguments;
+       }
       else if (fun_nargs < max_args)
        {
          Lisp_Object *p = spacious_args;
@@ -3203,8 +3193,7 @@ Thus, (funcall 'cons 'x 'y) returns (x . y).
        }
       else if (max_args == MANY)
        {
-         val = ((Lisp_Object (*) (int, Lisp_Object *)) (subr_function (subr)))
-           (fun_nargs, fun_args);
+         val = SUBR_FUNCTION (subr, MANY) (fun_nargs, fun_args);
        }
       else if (max_args == UNEVALLED) /* Can't funcall a special form */
        {
@@ -3213,7 +3202,7 @@ Thus, (funcall 'cons 'x 'y) returns (x . y).
       else
        {
        wrong_number_of_arguments:
-         signal_wrong_number_of_arguments_error (fun, fun_nargs);
+         val = signal_wrong_number_of_arguments_error (fun, fun_nargs);
        }
     }
   else if (COMPILED_FUNCTIONP (fun))
@@ -3240,12 +3229,12 @@ Thus, (funcall 'cons 'x 'y) returns (x . y).
     }
   else if (UNBOUNDP (fun))
     {
-      signal_void_function_error (args[0]);
+      val = signal_void_function_error (args[0]);
     }
   else
     {
     invalid_function:
-      signal_invalid_function_error (fun);
+      val = signal_invalid_function_error (fun);
     }
 
   lisp_eval_depth--;
@@ -3321,7 +3310,7 @@ function_argcount (Lisp_Object function, int function_min_args_p)
   else
     {
     invalid_function:
-      return Fsignal (Qinvalid_function, list1 (function));
+      return signal_invalid_function_error (function);
     }
 
   {
@@ -3508,10 +3497,10 @@ funcall_lambda (Lisp_Object fun, int nargs, Lisp_Object args[])
   return unbind_to (speccount, Fprogn (body));
 
  wrong_number_of_arguments:
-  return Fsignal (Qwrong_number_of_arguments, list2 (fun, make_int (nargs)));
+  return signal_wrong_number_of_arguments_error (fun, nargs);
 
  invalid_function:
-  return Fsignal (Qinvalid_function, list1 (fun));
+  return signal_invalid_function_error (fun);
 }
 
 \f
@@ -3627,8 +3616,9 @@ run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args,
     }
   else
     {
-      struct gcpro gcpro1, gcpro2;
-      GCPRO2 (sym, val);
+      struct gcpro gcpro1, gcpro2, gcpro3;
+      Lisp_Object globals = Qnil;
+      GCPRO3 (sym, val, globals);
 
       for (;
           CONSP (val) && ((cond == RUN_HOOKS_TO_COMPLETION)
@@ -3640,7 +3630,7 @@ run_hook_with_args_in_buffer (struct buffer *buf, int nargs, Lisp_Object *args,
            {
              /* t indicates this hook has a local binding;
                 it means to run the global binding too.  */
-             Lisp_Object globals = Fdefault_value (sym);
+             globals = Fdefault_value (sym);
 
              if ((! CONSP (globals) || EQ (XCAR (globals), Qlambda)) &&
                  ! NILP (globals))
@@ -4207,14 +4197,14 @@ eval_in_buffer_trapping_errors (CONST char *warning_string,
   /* gc_currently_forbidden = 1; Currently no reason to do this; */
 
   cons = noseeum_cons (buffer, form);
-  opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
+  opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
   GCPRO2 (cons, opaque);
   /* Qerror not Qt, so you can get a backtrace */
   tem = condition_case_1 (Qerror,
                           catch_them_squirmers_eval_in_buffer, cons,
                          caught_a_squirmer, opaque);
   free_cons (XCONS (cons));
-  if (OPAQUEP (opaque))
+  if (OPAQUE_PTRP (opaque))
     free_opaque_ptr (opaque);
   UNGCPRO;
 
@@ -4247,13 +4237,13 @@ run_hook_trapping_errors (CONST char *warning_string, Lisp_Object hook_symbol)
   speccount = specpdl_depth();
   specbind (Qinhibit_quit, Qt);
 
-  opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
+  opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
   GCPRO1 (opaque);
   /* Qerror not Qt, so you can get a backtrace */
   tem = condition_case_1 (Qerror,
                           catch_them_squirmers_run_hook, hook_symbol,
                           caught_a_squirmer, opaque);
-  if (OPAQUEP (opaque))
+  if (OPAQUE_PTRP (opaque))
     free_opaque_ptr (opaque);
   UNGCPRO;
 
@@ -4283,7 +4273,7 @@ safe_run_hook_trapping_errors (CONST char *warning_string,
     specbind (Qinhibit_quit, Qt);
 
   cons = noseeum_cons (hook_symbol,
-                      warning_string ? make_opaque_ptr (warning_string)
+                      warning_string ? make_opaque_ptr ((void *)warning_string)
                       : Qnil);
   GCPRO1 (cons);
   /* Qerror not Qt, so you can get a backtrace */
@@ -4294,7 +4284,7 @@ safe_run_hook_trapping_errors (CONST char *warning_string,
                          allow_quit_safe_run_hook_caught_a_squirmer :
                           safe_run_hook_caught_a_squirmer,
                          cons);
-  if (OPAQUEP (XCDR (cons)))
+  if (OPAQUE_PTRP (XCDR (cons)))
     free_opaque_ptr (XCDR (cons));
   free_cons (XCONS (cons));
   UNGCPRO;
@@ -4329,12 +4319,12 @@ call0_trapping_errors (CONST char *warning_string, Lisp_Object function)
   specbind (Qinhibit_quit, Qt);
   /* gc_currently_forbidden = 1; Currently no reason to do this; */
 
-  opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
+  opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
   /* Qerror not Qt, so you can get a backtrace */
   tem = condition_case_1 (Qerror,
                           catch_them_squirmers_call0, function,
                           caught_a_squirmer, opaque);
-  if (OPAQUEP (opaque))
+  if (OPAQUE_PTRP (opaque))
     free_opaque_ptr (opaque);
   UNGCPRO;
 
@@ -4379,12 +4369,12 @@ call1_trapping_errors (CONST char *warning_string, Lisp_Object function,
   /* gc_currently_forbidden = 1; Currently no reason to do this; */
 
   cons = noseeum_cons (function, object);
-  opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
+  opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
   /* Qerror not Qt, so you can get a backtrace */
   tem = condition_case_1 (Qerror,
                           catch_them_squirmers_call1, cons,
                           caught_a_squirmer, opaque);
-  if (OPAQUEP (opaque))
+  if (OPAQUE_PTRP (opaque))
     free_opaque_ptr (opaque);
   free_cons (XCONS (cons));
   UNGCPRO;
@@ -4415,12 +4405,12 @@ call2_trapping_errors (CONST char *warning_string, Lisp_Object function,
   /* gc_currently_forbidden = 1; Currently no reason to do this; */
 
   cons = list3 (function, object1, object2);
-  opaque = (warning_string ? make_opaque_ptr (warning_string) : Qnil);
+  opaque = (warning_string ? make_opaque_ptr ((void *)warning_string) : Qnil);
   /* Qerror not Qt, so you can get a backtrace */
   tem = condition_case_1 (Qerror,
                           catch_them_squirmers_call2, cons,
                           caught_a_squirmer, opaque);
-  if (OPAQUEP (opaque))
+  if (OPAQUE_PTRP (opaque))
     free_opaque_ptr (opaque);
   free_list (cons);
   UNGCPRO;
@@ -4473,7 +4463,7 @@ specbind_unwind_local (Lisp_Object ovalue)
 {
   Lisp_Object current = Fcurrent_buffer ();
   Lisp_Object symbol = specpdl_ptr->symbol;
-  struct Lisp_Cons *victim = XCONS (ovalue);
+  Lisp_Cons *victim = XCONS (ovalue);
   Lisp_Object buf = get_buffer (victim->car, 0);
   ovalue = victim->cdr;
 
@@ -4627,7 +4617,7 @@ unbind_to_hairy (int count)
        {
          /* We checked symbol for validity when we specbound it,
             so only need to call Fset if symbol has magic value.  */
-         struct Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
+         Lisp_Symbol *sym = XSYMBOL (specpdl_ptr->symbol);
          if (!SYMBOL_VALUE_MAGIC_P (sym->value))
            sym->value = specpdl_ptr->old_value;
          else
@@ -4753,7 +4743,7 @@ backtrace_specials (int speccount, int speclimit, Lisp_Object stream)
 
 DEFUN ("backtrace", Fbacktrace, 0, 2, "", /*
 Print a trace of Lisp function calls currently active.
-Option arg STREAM specifies the output stream to send the backtrace to,
+Optional arg STREAM specifies the output stream to send the backtrace to,
 and defaults to the value of `standard-output'.  Optional second arg
 DETAILED means show places where currently active variable bindings,
 catches, condition-cases, and unwind-protects were made as well as
@@ -4796,8 +4786,8 @@ function calls.
       if (!NILP (detailed) && catches && catches->backlist == backlist)
        {
           int catchpdl = catches->pdlcount;
-          if (specpdl[catchpdl].func == condition_case_unwind
-              && speccount > catchpdl)
+          if (speccount > catchpdl
+             && specpdl[catchpdl].func == condition_case_unwind)
             /* This is a condition-case catchpoint */
             catchpdl = catchpdl + 1;
 
@@ -5053,8 +5043,28 @@ reinit_eval (void)
 }
 
 void
+reinit_vars_of_eval (void)
+{
+  preparing_for_armageddon = 0;
+  in_warnings = 0;
+  Qunbound_suspended_errors_tag = make_opaque_ptr (&Qunbound_suspended_errors_tag);
+  staticpro_nodump (&Qunbound_suspended_errors_tag);
+
+  specpdl_size = 50;
+  specpdl = xnew_array (struct specbinding, specpdl_size);
+  /* XEmacs change: increase these values. */
+  max_specpdl_size = 3000;
+  max_lisp_eval_depth = 500;
+#if 0 /* no longer used */
+  throw_level = 0;
+#endif
+}
+
+void
 vars_of_eval (void)
 {
+  reinit_vars_of_eval ();
+
   DEFVAR_INT ("max-specpdl-size", &max_specpdl_size /*
 Limit on number of Lisp variable bindings & unwind-protects before error.
 */ );
@@ -5156,13 +5166,10 @@ If due to `eval' entry, one arg, t.
 */ );
   Vdebugger = Qnil;
 
-  preparing_for_armageddon = 0;
-
   staticpro (&Vpending_warnings);
   Vpending_warnings = Qnil;
-  Vpending_warnings_tail = Qnil; /* no need to protect this */
-
-  in_warnings = 0;
+  pdump_wire (&Vpending_warnings_tail);
+  Vpending_warnings_tail = Qnil;
 
   staticpro (&Vautoload_queue);
   Vautoload_queue = Qnil;
@@ -5175,18 +5182,5 @@ If due to `eval' entry, one arg, t.
   staticpro (&Vcurrent_error_state);
   Vcurrent_error_state = Qnil; /* errors as normal */
 
-  Qunbound_suspended_errors_tag = make_opaque_long (0);
-  staticpro (&Qunbound_suspended_errors_tag);
-
-  specpdl_size = 50;
-  specpdl_depth_counter = 0;
-  specpdl = xnew_array (struct specbinding, specpdl_size);
-  /* XEmacs change: increase these values. */
-  max_specpdl_size = 3000;
-  max_lisp_eval_depth = 500;
-#if 0 /* no longer used */
-  throw_level = 0;
-#endif
-
   reinit_eval ();
 }