comparison src/alloc.c @ 161:28f395d8dc7a r20-3b7

Import from CVS: tag r20-3b7
author cvs
date Mon, 13 Aug 2007 09:42:26 +0200
parents 7d55a9ba150c
children 0132846995bd
comparison
equal deleted inserted replaced
160:1c55655d6702 161:28f395d8dc7a
3954 garbage_collect_1 (void) 3954 garbage_collect_1 (void)
3955 { 3955 {
3956 char stack_top_variable; 3956 char stack_top_variable;
3957 extern char *stack_bottom; 3957 extern char *stack_bottom;
3958 int i; 3958 int i;
3959 struct frame *f = selected_frame ();
3960 int speccount = specpdl_depth (); 3959 int speccount = specpdl_depth ();
3961 Lisp_Object pre_gc_cursor = Qnil; 3960 Lisp_Object pre_gc_cursor = Qnil;
3961 Lisp_Object changed_frames = Qnil;
3962 struct gcpro gcpro1; 3962 struct gcpro gcpro1;
3963 3963
3964 int cursor_changed = 0; 3964 int cursor_changed_selected_frame = 0;
3965 3965
3966 if (gc_in_progress != 0) 3966 if (gc_in_progress != 0)
3967 return; 3967 return;
3968 3968
3969 if (gc_currently_forbidden || in_display) 3969 if (gc_currently_forbidden || in_display)
3970 return; 3970 return;
3971 3971
3972 if (preparing_for_armageddon) 3972 if (preparing_for_armageddon)
3973 return; 3973 return;
3974 3974
3975 GCPRO1 (pre_gc_cursor); 3975 GCPRO1 (changed_frames);
3976 3976
3977 /* Very important to prevent GC during any of the following 3977 /* Very important to prevent GC during any of the following
3978 stuff that might run Lisp code; otherwise, we'll likely 3978 stuff that might run Lisp code; otherwise, we'll likely
3979 have infinite GC recursion. */ 3979 have infinite GC recursion. */
3980 record_unwind_protect (restore_gc_inhibit, 3980 record_unwind_protect (restore_gc_inhibit,
3985 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook); 3985 run_hook_trapping_errors ("Error in pre-gc-hook", Qpre_gc_hook);
3986 3986
3987 /* Now show the GC cursor/message. */ 3987 /* Now show the GC cursor/message. */
3988 if (!noninteractive) 3988 if (!noninteractive)
3989 { 3989 {
3990 if (FRAME_WIN_P (f)) 3990 /* No need to gcpro this; gc won't catch us now. */
3991 Lisp_Object frmcons, devcons, concons;
3992 Lisp_Object selframe = make_frame (selected_frame ());
3993
3994 FRAME_LOOP_NO_BREAK (frmcons, devcons, concons)
3991 { 3995 {
3992 Lisp_Object frame = make_frame (f); 3996 struct frame *f = XFRAME (XCAR (frmcons));
3993 Lisp_Object cursor = glyph_image_instance (Vgc_pointer_glyph, 3997 int cursor_changed;
3994 FRAME_SELECTED_WINDOW (f), 3998
3995 ERROR_ME_NOT, 1); 3999 if (FRAME_WIN_P (f))
3996 pre_gc_cursor = f->pointer;
3997 if (POINTER_IMAGE_INSTANCEP (cursor)
3998 /* don't change if we don't know how to change back. */
3999 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
4000 { 4000 {
4001 cursor_changed = 1; 4001 Lisp_Object frame = XCAR (frmcons);
4002 Fset_frame_pointer (frame, cursor); 4002 Lisp_Object cursor =
4003 glyph_image_instance (Vgc_pointer_glyph,
4004 FRAME_SELECTED_WINDOW (f),
4005 ERROR_ME_NOT, 1);
4006 pre_gc_cursor = f->pointer;
4007 if (POINTER_IMAGE_INSTANCEP (cursor)
4008 /* don't change if we don't know how to change back. */
4009 && POINTER_IMAGE_INSTANCEP (pre_gc_cursor))
4010 {
4011 Fset_frame_pointer (frame, cursor);
4012 /* Add the frame to the list. */
4013 changed_frames = Fcons (pre_gc_cursor, changed_frames);
4014 changed_frames = Fcons (XCAR (frmcons), changed_frames);
4015 if (EQ (XCAR (frmcons), selframe))
4016 cursor_changed_selected_frame = 1;
4017 }
4003 } 4018 }
4004 } 4019 }
4005 4020 /* Now handle the plain old message. */
4006 /* Don't print messages to the stream device. */ 4021 {
4007 if (!cursor_changed && !FRAME_STREAM_P (f)) 4022 struct frame *f = XFRAME (selframe);
4008 { 4023 /* Don't print messages to the stream device. */
4009 char *msg = (STRINGP (Vgc_message) 4024 if (!cursor_changed_selected_frame && !FRAME_STREAM_P (f))
4010 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message)) 4025 {
4011 : 0); 4026 char *msg = (STRINGP (Vgc_message)
4012 Lisp_Object args[2], whole_msg; 4027 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4013 args[0] = build_string (msg ? msg : 4028 : 0);
4014 GETTEXT ((CONST char *) gc_default_message)); 4029 Lisp_Object args[2], whole_msg;
4015 args[1] = build_string ("..."); 4030 args[0] =
4016 whole_msg = Fconcat (2, args); 4031 build_string (msg ? msg :
4017 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1, 4032 GETTEXT ((CONST char *) gc_default_message));
4018 Qgarbage_collecting); 4033 args[1] = build_string ("...");
4019 } 4034 whole_msg = Fconcat (2, args);
4035 echo_area_message (f, (Bufbyte *) 0, whole_msg, 0, -1,
4036 Qgarbage_collecting);
4037 }
4038 }
4020 } 4039 }
4021 4040
4022 /***** Now we actually start the garbage collection. */ 4041 /***** Now we actually start the garbage collection. */
4023 4042
4024 gc_in_progress = 1; 4043 gc_in_progress = 1;
4150 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook); 4169 run_hook_trapping_errors ("Error in post-gc-hook", Qpost_gc_hook);
4151 4170
4152 /* Now remove the GC cursor/message */ 4171 /* Now remove the GC cursor/message */
4153 if (!noninteractive) 4172 if (!noninteractive)
4154 { 4173 {
4155 if (cursor_changed) 4174 Lisp_Object tail = changed_frames;
4156 Fset_frame_pointer (make_frame (f), pre_gc_cursor); 4175 while (CONSP (tail) && CONSP (XCDR (tail)))
4157 else if (!FRAME_STREAM_P (f)) 4176 {
4177 Fset_frame_pointer (XCAR (tail), XCAR (XCDR (tail)));
4178 tail = XCDR (XCDR (tail));
4179 }
4180 if (!cursor_changed_selected_frame && !FRAME_STREAM_P (selected_frame ()))
4158 { 4181 {
4159 char *msg = (STRINGP (Vgc_message) 4182 char *msg = (STRINGP (Vgc_message)
4160 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message)) 4183 ? GETTEXT ((char *) XSTRING_DATA (Vgc_message))
4161 : 0); 4184 : 0);
4162 4185