xemacs-beta: src/eval.c comparison

comparison src/eval.c @ 185:3d6bfa290dbd r20-3b19

Import from CVS: tag r20-3b19

author	cvs
date	Mon, 13 Aug 2007 09:55:28 +0200
parents	bfd6434d15b3
children	b405438285a2

comparison

equal deleted inserted replaced

-:bcd2674570bf
+:3d6bfa290dbd
 in the specpdl stack (used for variable bindings and
 unwind-protects), the value of LISP_EVAL_DEPTH, and the
 current position in the GCPRO stack.  All of these are
 restored by Fthrow().
 */
 struct catchtag *catchlist;
 Lisp_Object Qautoload, Qmacro, Qexit;
 Lisp_Object Qinteractive, Qcommandp, Qdefun, Qprogn, Qvalues;
 Lisp_Object Vquit_flag, Vinhibit_quit;
 invocations.  */
 int when_entered_debugger;
 #endif
 /* Nonzero means we are trying to enter the debugger.
 This is to prevent recursive attempts.
 Cleared by the debugger calling Fbacktrace */
 static int entering_debugger;
 /* Function to call to invoke the debugger */
 Lisp_Object Vdebugger;
 write_c_string (((subr->max_args == UNEVALLED)
 ? "#<special-form "
 : "#<subr "),
 printcharfun);
 write_c_string (subr_name (subr), printcharfun);
 write_c_string (((subr->prompt) ? " (interactive)>" : ">"),
 printcharfun);
 }
 	  && b1->flags.interactivep == b2->flags.interactivep
 	  && b1->flags.domainp == b2->flags.domainp /* I18N3 */
 	  && internal_equal (b1->bytecodes, b2->bytecodes, depth + 1)
 	  && internal_equal (b1->constants, b2->constants, depth + 1)
 	  && internal_equal (b1->arglist, b2->arglist, depth + 1)
 	  && internal_equal (b1->doc_and_interactive,
 			     b2->doc_and_interactive, depth + 1));
 }
 static unsigned long
 compiled_function_hash (Lisp_Object obj, int depth)
 if (specpdl_size + 40 > max_specpdl_size)
 max_specpdl_size = specpdl_size + 40;
 debug_on_next_call = 0;
 speccount = specpdl_depth_counter;
 record_unwind_protect (restore_entering_debugger,
 (entering_debugger ? Qt : Qnil));
 entering_debugger = 1;
 val = internal_catch (Qdebugger, call_debugger_259, arg, &threw);
 return unbind_to (speccount, ((threw)
 				? Qunbound /* Not returning a value */
 				: val));
 }
 /* Called when debug-on-exit behavior is called for.  Enter the debugger
 {
 specbind (Qdebug_on_error, Qnil);
 specbind (Qstack_trace_on_error, Qnil);
 specbind (Qdebug_on_signal, Qnil);
 specbind (Qstack_trace_on_signal, Qnil);
 internal_with_output_to_temp_buffer ("*Backtrace*",
 					   backtrace_259,
 					   Qnil,
 					   Qnil);
 unbind_to (speccount, Qnil);
 *stack_trace_displayed = 1;
 }
 if (!entering_debugger && !*debugger_entered && !signal_vars_only
 && (EQ (sig, Qquit)
 	  ? debug_on_quit
 	  : wants_debugger (Vdebug_on_error, conditions))
 && !skip_debugger (conditions, temp_data))
 debug_on_quit &= ~2;	/* reset critical bit */
 specbind (Qdebug_on_error, Qnil);
 specbind (Qstack_trace_on_error, Qnil);
 specbind (Qdebug_on_signal, Qnil);
 specbind (Qstack_trace_on_signal, Qnil);
 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
 *debugger_entered = 1;
 }
 if (!entering_debugger && !*stack_trace_displayed
 {
 specbind (Qdebug_on_error, Qnil);
 specbind (Qstack_trace_on_error, Qnil);
 specbind (Qdebug_on_signal, Qnil);
 specbind (Qstack_trace_on_signal, Qnil);
 internal_with_output_to_temp_buffer ("*Backtrace*",
 					   backtrace_259,
 					   Qnil,
 					   Qnil);
 unbind_to (speccount, Qnil);
 debug_on_quit &= ~2;	/* reset critical bit */
 specbind (Qdebug_on_error, Qnil);
 specbind (Qstack_trace_on_error, Qnil);
 specbind (Qdebug_on_signal, Qnil);
 specbind (Qstack_trace_on_signal, Qnil);
 val = call_debugger (list2 (Qerror, (Fcons (sig, data))));
 *debugger_entered = 1;
 }
 UNGCPRO;
 varlist = Fcar (args);
 /* Make space to hold the values to give the bound variables */
 elt = Flength (varlist);
-temps = (Lisp_Object *) alloca (XINT (elt) * sizeof (Lisp_Object));
+temps = alloca_array (Lisp_Object, XINT (elt));
 /* Compute the values and store them in `temps' */
 GCPRO2 (args, *temps);
 gcpro2.nvars = 0;
 UNGCPRO;
 return Qnil;
 }
-Lisp_Object Qsetq;
 DEFUN ("setq", Fsetq, 0, UNEVALLED, 0, /*
 (setq SYM VAL SYM VAL ...): set each SYM to the value of its VAL.
 The symbols SYM are variables; they are literal (not evaluated).
 The values VAL are expressions; they are evaluated.
 Thus, (setq x (1+ y)) sets `x' to the value of `(1+ y)'.
 while (!NILP (args_left));
 UNGCPRO;
 return val;
 }
 DEFUN ("quote", Fquote, 1, UNEVALLED, 0, /*
 Return the argument, without evaluating it.  `(quote x)' yields `x'.
 */
 (args))
 {
 return Fcar (args);
 }
 DEFUN ("function", Ffunction, 1, UNEVALLED, 0, /*
 Like `quote', but preferred for objects which are functions.
 In byte compilation, `function' causes its argument to be compiled.
 `quote' cannot do that.
 */
 for the variable is `*'.
 */
 (variable))
 {
 Lisp_Object documentation;
 documentation = Fget (variable, Qvariable_documentation, Qnil);
 if (INTP (documentation) && XINT (documentation) < 0)
 return Qt;
 if ((STRINGP (documentation)) &&
 (string_byte (XSTRING (documentation), 0) == '*'))
 && STRINGP (XCAR (documentation))
 && INTP (XCDR (documentation))
 && XINT (XCDR (documentation)) < 0)
 return Qt;
 return Qnil;
 }
 DEFUN ("macroexpand-internal", Fmacroexpand_internal, 1, 2, 0, /*
 Return result of expanding macros at top level of FORM.
 If FORM is not a macro call, it is returned unchanged.
 Otherwise, the macro is expanded and the expansion is considered
 /* Set up a catch, then call C function FUNC on argument ARG.
 FUNC should return a Lisp_Object.
 This is how catches are done from within C code. */
 Lisp_Object
 internal_catch (Lisp_Object tag,
 Lisp_Object (*func) (Lisp_Object arg),
 Lisp_Object arg,
 int *threw)
 {
 /* This structure is made part of the chain `catchlist'.  */
 At the end, restore some static info saved in CATCH,
 and longjmp to the location specified.
 */
 /* Save the value somewhere it will be GC'ed.
 (Can't overwrite tag slot because an unwind-protect may
 want to throw to this same tag, which isn't yet invalid.) */
 c->val = val;
 #if 0 /* FSFmacs */
 /* Restore the polling-suppression count.  */
 backtrace_list = c->backlist;
 lisp_eval_depth = c->lisp_eval_depth;
 throw_level = 0;
 LONGJMP (c->jmp, 1);
 }
 static DOESNT_RETURN
 throw_or_bomb_out (Lisp_Object tag, Lisp_Object val, int bomb_out_p,
 		   Lisp_Object sig, Lisp_Object data)
 {
 occurs is when there's no catch for 'top-level -- the
 'top-level catch and the catch-all error handler are
 established at the same time, in initial_command_loop/
 top_level_1.
 #### Fix this horrifitude!
 */
 while (1)
 {
 REGISTER struct catchtag *c;
 #if 0 /* FSFmacs */
 /* This function can GC */
 #if 0 /* FSFmacs */
 if (!NILP (h.var))
 specbind (h.var, c.val);
 val = Fprogn (Fcdr (h.chosen_clause));
 /* Note that this just undoes the binding of h.var; whoever
 longjumped to us unwound the stack to c.pdlcount before
 throwing. */
 unbind_to (c.pdlcount, Qnil);
 return val;
 /* Here for bytecode to call non-consfully.  This is exactly like
 condition-case except that it takes three arguments rather
 than a single list of arguments. */
 Lisp_Object
 Fcondition_case_3 (Lisp_Object bodyform,
 Lisp_Object var, Lisp_Object handlers)
 {
 /* This function can GC */
 Lisp_Object val;
 for (val = handlers; ! NILP (val); val = Fcdr (val))
 {
 Lisp_Object tem;
 tem = Fcar (val);
 if ((!NILP (tem))
 && (!CONSP (tem)
 	      || (!SYMBOLP (XCAR (tem)) && !CONSP (XCAR (tem)))))
 	signal_simple_error ("Invalid condition handler", tem);
 }
 return condition_case_1 (handlers,
 Feval, bodyform,
 run_condition_case_handlers,
 var);
 }
 {
 /* This function can GC */
 return Fcondition_case_3 (Fcar (Fcdr (args)),
 Fcar (args),
 Fcdr (Fcdr (args)));
 }
 DEFUN ("call-with-condition-handler", Fcall_with_condition_handler, 2, MANY, 0, /*
 Regain control when an error is signalled, without popping the stack.
 Usage looks like (call-with-condition-handler HANDLER FUNCTION &rest ARGS).
 This function is similar to `condition-case', but the handler is invoked
 Vcondition_handlers = all_handlers;
 }
 /* It's a condition-case handler */
 /* t is used by handlers for all conditions, set up by C code.
 *  debugger is not called even if debug_on_error */
 else if (EQ (handler_data, Qt))
 	{
 UNGCPRO;
 return Fthrow (handlers, Fcons (sig, data));
 #### The only time that no handler is present is during
 temacs or perhaps very early in XEmacs.  In both cases,
 there is no 'top-level catch. (That's why the
 "bomb-out" hack was added.)
 #### Fix this horrifitude!
 */
 signal_call_debugger (conditions, sig, data, Qnil, 0,
 			&stack_trace_displayed,
 			&debugger_entered);
 UNGCPRO;
 errb = ERROR_ME_NOT;
 no_error = Qt;
 }
 else
 no_error = Qnil;
 va_start (vargs, nargs);
 for (i = 0; i < nargs; i++)
 args[i] = va_arg (vargs, Lisp_Object);
 va_end (vargs);
 /* If error-checking is not disabled, just call the function.
 It's important not to override disabled error-checking with
 enabled error-checking. */
 if (ERRB_EQ (errb, ERROR_ME))
 return primitive_funcall (fun, nargs, args);
 speccount = specpdl_depth ();
 if (NILP (class) || NILP (Vcurrent_warning_class))
 if (ERRB_EQ (errb, ERROR_ME_NOT))
 return Qnil;
 return maybe_signal_continuable_error
 (Qerror, list2 (build_translated_string (reason),
 		    frob), class, errb);
 }
 /****************** Error functions class 4 ******************/
 /* Class 4: Printf-like functions that signal an error.
 signal_quit (void)
 {
 /* This function can GC */
 if (EQ (Vquit_flag, Qcritical))
 debug_on_quit |= 2;		/* set critical bit. */
 Vquit_flag = Qnil;
 /* note that this is continuable. */
 Fsignal (Qquit, Qnil);
 }
 if (EQ (*btp->function, Qbyte_code))
 btp = btp->next;
 /* If this isn't a byte-compiled function, then we may now be
 looking at several frames for special forms.  Skip past them.  */
 while (btp &&
 	 btp->nargs == UNEVALLED)
 btp = btp->next;
 #else
 {
 /* Attempt to avoid consing identical (string=) pure strings. */
 file = Fsymbol_name (Fintern (file, Qnil));
 }
 return Ffset (function,
 Fpurecopy (Fcons (Qautoload, list4 (file,
 docstring,
 interactive,
 type))));
 }
 }
 return Qnil;
 }
 void
 do_autoload (Lisp_Object fundef,
 Lisp_Object funname)
 {
 /* This function can GC */
 int speccount = specpdl_depth_counter;
 Lisp_Object fun = funname;
 /**********************************************************************/
 /*                         eval, funcall, apply                       */
 /**********************************************************************/
 static Lisp_Object funcall_lambda (Lisp_Object fun,
 int nargs, Lisp_Object args[]);
 static Lisp_Object apply_lambda (Lisp_Object fun,
 int nargs, Lisp_Object args);
 static Lisp_Object funcall_subr (struct Lisp_Subr *sub, Lisp_Object args[]);
 static int in_warnings;
 free_cons (XCONS (this_warning_cons));
 class = XCAR (this_warning);
 level = XCAR (XCDR (this_warning));
 messij = XCAR (XCDR (XCDR (this_warning)));
 free_list (this_warning);
 if (NILP (Vpending_warnings))
 	Vpending_warnings_tail = Qnil; /* perhaps not strictly necessary,
 					  but safer */
 GCPRO4 (form, class, level, messij);
 args_left = original_args;
 if (nargs < subr->min_args
 	  || (max_args >= 0 && max_args < nargs))
 	{
 	  return Fsignal (Qwrong_number_of_arguments,
 			  list2 (fun, make_int (nargs)));
 	}
 if (max_args == UNEVALLED)
 	{
 	  /* Pass a vector of evaluated arguments */
 	  Lisp_Object *vals;
 	  REGISTER int argnum;
 struct gcpro gcpro1, gcpro2, gcpro3;
-	  vals = (Lisp_Object *) alloca (nargs * sizeof (Lisp_Object));
+	  vals = alloca_array (Lisp_Object, nargs);
 	  GCPRO3 (args_left, fun, vals[0]);
 	  gcpro3.nvars = 0;
 	  argnum = 0;
 	  for (i = 0; i < nargs; args_left = Fcdr (args_left))
 	    {
 	      argvals[i] = Feval (Fcar (args_left));
 	      gcpro3.nvars = ++i;
 	    }
 	  UNGCPRO;
 	  for (i = nargs; i < max_args; i++)
 argvals[i] = Qnil;
 backtrace.args = argvals;
 backtrace.nargs = nargs;
 	return Fsignal (Qinvalid_function, list1 (fun));
 if (nargs < subr->min_args
 	  || (max_args >= 0 && max_args < nargs))
 	{
 	  return Fsignal (Qwrong_number_of_arguments,
 list2 (fun, make_int (nargs)));
 	}
 if (max_args == MANY)
 	{
 Lisp_Object spread_arg = args [nargs - 1];
 int numargs;
 int funcall_nargs;
 CHECK_LIST (spread_arg);
 numargs = XINT (Flength (spread_arg));
 if (numargs == 0)
 /* (apply foo 0 1 '()) */
 return Ffuncall (nargs - 1, args);
 funcall_nargs += (max_args - numargs);
 }
 }
 {
 REGISTER int i;
-REGISTER Lisp_Object *funcall_args
+Lisp_Object *funcall_args = alloca_array (Lisp_Object, funcall_nargs);
-= (Lisp_Object *) alloca (funcall_nargs * sizeof (Lisp_Object));
 struct gcpro gcpro1;
 GCPRO1 (*funcall_args);
 gcpro1.nvars = funcall_nargs;
 /* Copy in the unspread args */
 memcpy (funcall_args, args, (nargs - 1) * sizeof (Lisp_Object));
 /* Spread the last arg we got.  Its first element goes in
 the slot that it used to occupy, hence this value of I.  */
 for (i = nargs - 1;
 !NILP (spread_arg);    /* i < 1 + numargs */
 i++, spread_arg = XCDR (spread_arg))
 {
 	funcall_args [i] = XCAR (spread_arg);
 }
 {
 /* This function can GC */
 struct gcpro gcpro1, gcpro2, gcpro3;
 REGISTER int i;
 REGISTER Lisp_Object tem;
-REGISTER Lisp_Object *arg_vector
+REGISTER Lisp_Object *arg_vector = alloca_array (Lisp_Object, numargs);
-= (Lisp_Object *) alloca (numargs * sizeof (Lisp_Object));
 GCPRO3 (*arg_vector, unevalled_args, fun);
 gcpro1.nvars = 0;
 for (i = 0; i < numargs;)
 	{
 	  tem = arg_vector[i++];
 	  specbind (next, tem);
 	}
 else if (!optional)
 	return Fsignal (Qwrong_number_of_arguments,
 list2 (fun, make_int (nargs)));
 else
 	specbind (next, Qnil);
 }
 if (i < nargs)
 return Fsignal (Qwrong_number_of_arguments,
 list2 (fun, make_int (nargs)));
 if (CONSP (fun))
 val = Fprogn (Fcdr (Fcdr (fun)));
 else
 run_hook_with_args (1, hook, RUN_HOOKS_TO_COMPLETION);
 }
 return Qnil;
 }
 DEFUN ("run-hook-with-args", Frun_hook_with_args, 1, MANY, 0, /*
 Run HOOK with the specified arguments ARGS.
 HOOK should be a symbol, a hook variable.  If HOOK has a non-nil
 value, that value may be a function or a list of functions to be
 called to run the hook.  If the value is a function, it is called with
 {
 /* This function can GC */
 struct gcpro gcpro1;
 int i;
 va_list vargs;
-Lisp_Object *funcall_args =
+Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
-(Lisp_Object *) alloca ((1 + nargs) * sizeof (Lisp_Object));
 va_start (vargs, nargs);
 funcall_args[0] = hook_var;
 for (i = 0; i < nargs; i++)
 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
 {
 /* This function can GC */
 struct gcpro gcpro1;
 int i;
 va_list vargs;
-Lisp_Object *funcall_args =
+Lisp_Object *funcall_args = alloca_array (Lisp_Object, 1 + nargs);
-(Lisp_Object *) alloca ((1 + nargs) * sizeof (Lisp_Object));
 va_start (vargs, nargs);
 funcall_args[0] = hook_var;
 for (i = 0; i < nargs; i++)
 funcall_args[i + 1] = va_arg (vargs, Lisp_Object);
 call1 (Lisp_Object fn,
 Lisp_Object arg0)
 {
 /* This function can GC */
 struct gcpro gcpro1;
 Lisp_Object args[2];
 args[0] = fn;
 args[1] = arg0;
 GCPRO1 (args[0]);
 gcpro1.nvars = 2;
 RETURN_UNGCPRO (Ffuncall (2, args));
 }
 /* Call function fn with arguments arg0, arg1, arg2, arg3, arg4 */
 Lisp_Object
 call5 (Lisp_Object fn,
 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
 Lisp_Object arg3, Lisp_Object arg4)
 {
 /* This function can GC */
 struct gcpro gcpro1;
 Lisp_Object args[6];
 RETURN_UNGCPRO (Ffuncall (6, args));
 }
 Lisp_Object
 call6 (Lisp_Object fn,
 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5)
 {
 /* This function can GC */
 struct gcpro gcpro1;
 Lisp_Object args[7];
 RETURN_UNGCPRO (Ffuncall (7, args));
 }
 Lisp_Object
 call7 (Lisp_Object fn,
 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
 Lisp_Object arg6)
 {
 /* This function can GC */
 struct gcpro gcpro1;
 RETURN_UNGCPRO (Ffuncall (8, args));
 }
 Lisp_Object
 call8 (Lisp_Object fn,
 Lisp_Object arg0, Lisp_Object arg1, Lisp_Object arg2,
 Lisp_Object arg3, Lisp_Object arg4, Lisp_Object arg5,
 Lisp_Object arg6, Lisp_Object arg7)
 {
 /* This function can GC */
 struct gcpro gcpro1;
 QUIT is inhibited while these functions are running, and if
 an error occurs, Qunbound is returned instead of the normal
 return value.
 */
 /* #### This stuff needs to catch throws as well.  We need to
 improve internal_catch() so it can take a "catch anything"
 argument similar to Qt or Qerror for condition_case_1(). */
 static Lisp_Object
 caught_a_squirmer (Lisp_Object errordata, Lisp_Object arg)
 {
 if (!NILP (errordata))
 {
 Lisp_Object args[2];
 if (!NILP (arg))
 {
 char *str = (char *) get_opaque_ptr (arg);
 args[0] = build_string (str);
 }
 			  caught_a_squirmer, opaque);
 free_cons (XCONS (cons));
 if (OPAQUEP (opaque))
 free_opaque_ptr (opaque);
 UNGCPRO;
 /* gc_currently_forbidden = 0; */
 return unbind_to (speccount, tem);
 }
 static Lisp_Object
 return Qnil;
 if (!allow_quit)
 specbind (Qinhibit_quit, Qt);
 cons = noseeum_cons (hook_symbol,
 		       warning_string ? make_opaque_ptr (warning_string)
 		       : Qnil);
 GCPRO1 (cons);
 /* Qerror not Qt, so you can get a backtrace */
 tem = condition_case_1 (Qerror,
 caught_a_squirmer, opaque);
 if (OPAQUEP (opaque))
 free_opaque_ptr (opaque);
 free_cons (XCONS (cons));
 UNGCPRO;
 /* gc_currently_forbidden = 0; */
 return unbind_to (speccount, tem);
 }
 Lisp_Object
 	}
 }
 specpdl_size *= 2;
 if (specpdl_size > max_specpdl_size)
 specpdl_size = max_specpdl_size;
-specpdl = ((struct specbinding *)
+XREALLOC_ARRAY (specpdl, struct specbinding, specpdl_size);
-	     xrealloc (specpdl, specpdl_size * sizeof (struct specbinding)));
 specpdl_ptr = specpdl + specpdl_depth_counter;
 }
 /* Handle unbinding buffer-local variables */
 {
 /* About to become buffer-local */
 specpdl_ptr->old_value = Fcurrent_buffer ();
 specpdl_ptr->func = specbind_unwind_wasnt_local;
 }
 specpdl_ptr->symbol = symbol;
 specpdl_ptr++;
 specpdl_depth_counter++;
 Fset (symbol, value);
 	  ptr->old_value = newval;
 	  return newval;
 	}
 }
 return Fset (symbol, newval);
 }
 #endif /* 0 */
 /**********************************************************************/
 Print a trace of Lisp function calls currently active.
 Option 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
 function calls.
 */
 (stream, detailed))
 {
 struct backtrace *backlist = backtrace_list;
 struct catchtag *catches = catchlist;
 int catchpdl = catches->pdlcount;
 if (specpdl[catchpdl].func == condition_case_unwind
 && speccount > catchpdl)
 /* This is a condition-case catchpoint */
 catchpdl = catchpdl + 1;
 backtrace_specials (speccount, catchpdl, stream);
 speccount = catches->pdlcount;
 if (catchpdl == speccount)
 	    {
 Qunbound_suspended_errors_tag = make_opaque_long (0);
 staticpro (&Qunbound_suspended_errors_tag);
 specpdl_size = 50;
 specpdl_depth_counter = 0;
-specpdl = (struct specbinding *)
+specpdl = xnew_array (struct specbinding, specpdl_size);
-xmalloc (specpdl_size * sizeof (struct specbinding));
 /* XEmacs change: increase these values. */
 max_specpdl_size = 3000;
 max_lisp_eval_depth = 500;
 throw_level = 0;

Mercurial > hg > xemacs-beta

comparison src/eval.c @ 185:3d6bfa290dbd r20-3b19