transpose-regions

transpose-regions

[martin rudalics]

I'm quite frequently harassed by reports like

Debugger entered--Lisp error: (wrong-type-argument listp 4297150)
   transpose-regions(44516 44561 44561 44599)

Debugger entered--Lisp error: (wrong-type-argument listp 4479113)
   transpose-regions(64984 65044 65044 65059)

Debugger entered--Lisp error: (wrong-type-argument listp 4626696)
   transpose-regions(130041 130061 130061 130225)

Erratically and unreproducible.  Apparently, the transposed regions are
always adjacent, I don't see a common pattern as far as their sizes are
concerned.

Breaking at Fsignal gave:

#0  Fsignal (error_symbol=23761593, data=24130861) at eval.c:1620
#1  0x0100cd68 in xsignal (error_symbol=23761593, data=24130861) at eval.c:1722
#2  0x0100cfb7 in xsignal2 () at eval.c:1746
#3  0x01004620 in pure_write_error () at data.c:121
#4  0x0107e521 in Flength (sequence=35483205) at fns.c:185
#5  0x0107f1e0 in concat (nargs=1, args=0xd2f280, target_type=Lisp_Cons, last_special=0) at fns.c:608
#6  0x0107f873 in Fcopy_sequence (arg=35483205) at fns.c:537
#7  0x0111ac12 in copy_properties (source=0x21db988, target=0x1eb79c0) at intervals.c:106
#8  0x0111be5f in graft_intervals_into_buffer (source=0x21db9f8, position=4778, length=322, buffer=0x20a2a00, inherit=0) at intervals.c:1842
#9  0x0108f6fb in Ftranspose_regions (startr1=38216, endr1=40792, startr2=40792, endr2=40800, leave_markers=23697409) at editfns.c:4214
#10 0x0100c87b in Ffuncall (nargs=5, args=0xd2f590) at eval.c:3011
#11 0x0110f83f in Fbyte_code (bytestr=33408387, vector=33639812, maxdepth=40) at bytecode.c:679
#12 0x0100bdcd in Feval (form=33251485) at eval.c:2334
#13 0x0100e1da in internal_lisp_condition_case (var=23697409, bodyform=33251485, handlers=33250773) at eval.c:1426
#14 0x0110ffe0 in Fbyte_code (bytestr=33408403, vector=33639684, maxdepth=24) at bytecode.c:869
#15 0x0100c274 in funcall_lambda (fun=33034660, nargs=0, arg_vector=0xd2f924) at eval.c:3184
#16 0x0100c6c6 in Ffuncall (nargs=1, args=0xd2f920) at eval.c:3054
#17 0x0100df03 in apply1 (fn=33611281, arg=23697409) at eval.c:2738
#18 0x0110e61c in Fcall_interactively (function=33611281, record_flag=23697409, keys=23756804) at callint.c:406
#19 0x01057506 in Fcommand_execute (cmd=33611281, record_flag=23697409, keys=23697409, special=23697409) at keyboard.c:10013
#20 0x0105e2bd in command_loop_1 () at keyboard.c:1873
#21 0x0100aa24 in internal_condition_case (bfun=0x105df60 <command_loop_1>, handlers=23761545, hfun=0x1057f40 <cmd_error>) at eval.c:1481
#22 0x01051f6e in command_loop_2 () at keyboard.c:1329
#23 0x0100a949 in internal_catch (tag=23755777, func=0x1051f40 <command_loop_2>, arg=23697409) at eval.c:1222
#24 0x01051d7e in command_loop () at keyboard.c:1308
#25 0x01051e1f in recursive_edit_1 () at keyboard.c:1006
#26 0x01051f1c in Frecursive_edit () at keyboard.c:1067
#27 0x01002a75 in main (argc=1, argv=0x19a06a0) at emacs.c:1761
#28 0x010011e7 in _end__ ()
#29 0x01001238 in mainCRTStartup ()
#30 0xbff7b9e4 in _libwinspool_a_iname ()
#31 0xbff7b896 in _libwinspool_a_iname ()
#32 0xbff7a24f in _libwinspool_a_iname ()

Re: transpose-regions

[Kim F. Storm]

martin rudalics <rudalics@gmx.at> writes:

> I'm quite frequently harassed by reports like
>
> Debugger entered--Lisp error: (wrong-type-argument listp 4297150)
>   transpose-regions(44516 44561 44561 44599)
>
> Debugger entered--Lisp error: (wrong-type-argument listp 4479113)
>   transpose-regions(64984 65044 65044 65059)
>
> Debugger entered--Lisp error: (wrong-type-argument listp 4626696)
>   transpose-regions(130041 130061 130061 130225)
>
> Erratically and unreproducible.  Apparently, the transposed regions are
> always adjacent, I don't see a common pattern as far as their sizes are
> concerned.
>
> Breaking at Fsignal gave:
>
> #0  Fsignal (error_symbol=23761593, data=24130861) at eval.c:1620
> #1  0x0100cd68 in xsignal (error_symbol=23761593, data=24130861) at eval.c:1722
> #2  0x0100cfb7 in xsignal2 () at eval.c:1746
> #3  0x01004620 in pure_write_error () at data.c:121
> #4  0x0107e521 in Flength (sequence=35483205) at fns.c:185
> #5  0x0107f1e0 in concat (nargs=1, args=0xd2f280, target_type=Lisp_Cons, last_special=0) at fns.c:608
> #6  0x0107f873 in Fcopy_sequence (arg=35483205) at fns.c:537
> #7  0x0111ac12 in copy_properties (source=0x21db988, target=0x1eb79c0) at intervals.c:106
> #8  0x0111be5f in graft_intervals_into_buffer (source=0x21db9f8, position=4778, length=322, buffer=0x20a2a00, inherit=0) at intervals.c:1842
> #9  0x0108f6fb in Ftranspose_regions (startr1=38216, endr1=40792, startr2=40792, endr2=40800, leave_markers=23697409) at editfns.c:4214
> #10 0x0100c87b in Ffuncall (nargs=5, args=0xd2f590) at eval.c:3011
> #11 0x0110f83f in Fbyte_code (bytestr=33408387, vector=33639812, maxdepth=40) at bytecode.c:679
> #12 0x0100bdcd in Feval (form=33251485) at eval.c:2334
> #13 0x0100e1da in internal_lisp_condition_case (var=23697409, bodyform=33251485, handlers=33250773) at eval.c:1426
> #14 0x0110ffe0 in Fbyte_code (bytestr=33408403, vector=33639684, maxdepth=24) at bytecode.c:869
> #15 0x0100c274 in funcall_lambda (fun=33034660, nargs=0, arg_vector=0xd2f924) at eval.c:3184
> #16 0x0100c6c6 in Ffuncall (nargs=1, args=0xd2f920) at eval.c:3054
> #17 0x0100df03 in apply1 (fn=33611281, arg=23697409) at eval.c:2738
> #18 0x0110e61c in Fcall_interactively (function=33611281, record_flag=23697409, keys=23756804) at callint.c:406
> #19 0x01057506 in Fcommand_execute (cmd=33611281, record_flag=23697409, keys=23697409, special=23697409) at keyboard.c:10013
> #20 0x0105e2bd in command_loop_1 () at keyboard.c:1873
> #21 0x0100aa24 in internal_condition_case (bfun=0x105df60 <command_loop_1>, handlers=23761545, hfun=0x1057f40 <cmd_error>) at eval.c:1481
> #22 0x01051f6e in command_loop_2 () at keyboard.c:1329
> #23 0x0100a949 in internal_catch (tag=23755777, func=0x1051f40 <command_loop_2>, arg=23697409) at eval.c:1222
> #24 0x01051d7e in command_loop () at keyboard.c:1308
> #25 0x01051e1f in recursive_edit_1 () at keyboard.c:1006
> #26 0x01051f1c in Frecursive_edit () at keyboard.c:1067
> #27 0x01002a75 in main (argc=1, argv=0x19a06a0) at emacs.c:1761
> #28 0x010011e7 in _end__ ()
> #29 0x01001238 in mainCRTStartup ()
> #30 0xbff7b9e4 in _libwinspool_a_iname ()
> #31 0xbff7b896 in _libwinspool_a_iname ()
> #32 0xbff7a24f in _libwinspool_a_iname ()

Martin sent me this additional info:

Hmmm ...

(gdb) xbacktrace
"transpose-regions" (0xc6c0)
"byte-code" (0x1fd43b3)
"m&d-drag-line-up" (0x1699801)
"call-interactively" (0x2002229)
(gdb) up 6
#6  0x0107f873 in Fcopy_sequence (arg=35173925) at fns.c:537
(gdb) pp arg

Program received signal SIGILL, Illegal instruction.
0x00d2ec07 in ?? ()
(gdb) pp arg
(gdb) ppt
BUF PT: 7879 of 1..132090 GAP: 132090 SZ=2000

.. where

(defun m&d-drag-line-up (&optional beg end)
  "Drag region up by one line. Region defaults to current line.
Region is always rounded up to whole lines."
  (interactive)
  (let* ((beg (save-excursion
		(goto-char
		 (or beg (and mark-active (min (point) (mark))) (point)))
		(line-beginning-position)))
	 (end (save-excursion
		(goto-char
		 (or end (and mark-active (max (point) (mark)))
		     (line-beginning-position 2)))
		(if (bolp) (point) (line-beginning-position 2))))
	 (point-beg (and (<= beg (point)) (<= (point) end)
			 (- (point) beg)))
	 (mark-beg (and mark-active (<= beg (mark)) (<= (mark) end)
			(- (mark) beg)))
	 (from (save-excursion
		 (goto-char beg)
		 (line-beginning-position 0)))
	 (recenter (when (= from (window-start))
		     (count-lines beg end))))
    (condition-case nil
	;; Wrapped in condition-case until we find out why `transpose-regions'
	;; is broken.
	(if (> beg from)
	    (progn
	      (if (save-excursion (goto-char end) (not (bolp)))
		  ;; Probably at eob.
		  (transpose-regions from (1- beg) beg end)
		(transpose-regions from beg beg end))
	      (when mark-beg
		(set-mark (+ mark-beg from))
		(setq deactivate-mark nil))
	      (when point-beg
		(goto-char (+ point-beg from)))
	      (when recenter
		(recenter recenter)))
	  (m&d-ensure-mark)
	  (message "Can't drag")
	  (ding))
      (error (m&d-ensure-mark)))))

-- 
Kim F. Storm <storm@cua.dk> http://www.cua.dk

Re: transpose-regions

[Chong Yidong]

martin rudalics <rudalics@gmx.at> writes:

> #4  0x0107e521 in Flength (sequence=35483205) at fns.c:185
> #5  0x0107f1e0 in concat (nargs=1, args=0xd2f280, target_type=Lisp_Cons, last_special=0) at fns.c:608
> #6  0x0107f873 in Fcopy_sequence (arg=35483205) at fns.c:537

In frame 4, could you find out what `sequence' is, if not a sequence?

p sequence
xtype
(xsymbol/xstring/etc...)

Re: transpose-regions

[martin rudalics]

Chong Yidong schrieb:
> martin rudalics <rudalics@gmx.at> writes:
> 
> 
>>#4  0x0107e521 in Flength (sequence=35483205) at fns.c:185
>>#5  0x0107f1e0 in concat (nargs=1, args=0xd2f280, target_type=Lisp_Cons, last_special=0) at fns.c:608
>>#6  0x0107f873 in Fcopy_sequence (arg=35483205) at fns.c:537
> 
> 
> In frame 4, could you find out what `sequence' is, if not a sequence?
> 
> p sequence
> xtype
> (xsymbol/xstring/etc...)
> 


Breakpoint 3, Fsignal (error_symbol=23761593, data=33053189) at eval.c:1620
(gdb) up 4
#4  0x0107e521 in Flength (sequence=35211917) at fns.c:185
(gdb) p sequence
$1 = 35211904
(gdb) xtype
Lisp_Int
(gdb) xsymbol
$2 = (struct Lisp_Symbol *) 0x2194a80
0

Re: transpose-regions

[Chong Yidong]

martin rudalics <rudalics@gmx.at> writes:

> Breakpoint 3, Fsignal (error_symbol=23761593, data=33053189) at eval.c:1620
> (gdb) up 4
> #4  0x0107e521 in Flength (sequence=35211917) at fns.c:185
> (gdb) p sequence
> $1 = 35211904
> (gdb) xtype
> Lisp_Int
> (gdb) xsymbol
> $2 = (struct Lisp_Symbol *) 0x2194a80
> 0

That implies that in fns.c:607:concat, the value of args[0], which is
the argument passed to Flength, is 35211917, a Lisp integer.

However, this makes no sense, because just a few lines above that, we
check the type of arg[0]:

  for (argnum = 0; argnum < nargs; argnum++)
    {
      this = args[argnum];
      if (!(CONSP (this) || NILP (this) || VECTORP (this) || STRINGP (this)
	    || COMPILEDP (this) || BOOL_VECTOR_P (this)))
	wrong_type_argument (Qsequencep, this);
    }

So could you please check that in frame 5, argnum is indeed 0 and
args[0] is 35211917, and check the xtype of args[0] in that frame?

Re: transpose-regions

[martin rudalics]

Sorry, the last session stalled, here's another one:

(gdb)
Continuing.

Breakpoint 3, Fsignal (error_symbol=23761593, data=24233677) at eval.c:1620
(gdb) up 4
#4  0x0107e521 in Flength (sequence=35193781) at fns.c:185
(gdb) p sequence
$1 = 35193768
(gdb) xtype
Lisp_Int
(gdb) xsymbol
$2 = (struct Lisp_Symbol *) 0x21903a8
0
(gdb) up 1
#5  0x0107f1e0 in concat (nargs=1, args=0xd2eea0, target_type=Lisp_Cons, last_special=0) at fns.c:608
(gdb) p argnum
$3 = 0
(gdb) p args[0]
$4 = 35193781
(gdb) xtype args[0]
Lisp_Cons
(gdb)

Re: transpose-regions

[Chong Yidong]

martin rudalics <rudalics@gmx.at> writes:

> #4  0x0107e521 in Flength (sequence=35193781) at fns.c:185
> (gdb) p sequence
> $1 = 35193768
> (gdb) xtype
> Lisp_Int
> (gdb) xsymbol
> $2 = (struct Lisp_Symbol *) 0x21903a8
> 0

Could you double check this?

Flength was called with sequence=35193781; how did it mutate into
35193768?  The code in Flength doesn't change the value of sequence
(unless it is a cons cell, in which case it wouldn't end up in the
"else" code path.)  The only way this could happen is if something
clobbers the stack.... maybe a compiler bug?

Re: transpose-regions

[martin rudalics]

 >>#4  0x0107e521 in Flength (sequence=35193781) at fns.c:185
 >>(gdb) p sequence
 >>$1 = 35193768
 >>(gdb) xtype
 >>Lisp_Int
 >>(gdb) xsymbol
 >>$2 = (struct Lisp_Symbol *) 0x21903a8
 >>0
 >
 >
 > Could you double check this?
 >
 > Flength was called with sequence=35193781; how did it mutate into
 > 35193768?  The code in Flength doesn't change the value of sequence
 > (unless it is a cons cell, in which case it wouldn't end up in the
 > "else" code path.)  The only way this could happen is if something
 > clobbers the stack.... maybe a compiler bug?

OK, here's another one.  At least they always differ by the same value.

I'm also puzzled by the

#3  0x01004620 in pure_write_error () at data.c:121

which should be wrong_type_argument (predicate, value).  I could send
you the Elisp code I use to trigger this.  You'd have to play around
with it a bit, though.

(gdb) break eval.c:1620
Breakpoint 3 at 0x100cb04: file eval.c, line 1620.
(gdb) run
Starting program: c:/Programme/Emacs/bin/emacs.exe -geometry 80x40+0+0
(gdb) cont
Continuing.

Breakpoint 3, Fsignal (error_symbol=23881689, data=34333301) at eval.c:1620
(gdb)
Continuing.

Breakpoint 3, Fsignal (error_symbol=23881689, data=34957365) at eval.c:1620
(gdb)
Continuing.

Breakpoint 3, Fsignal (error_symbol=23761593, data=33773717) at eval.c:1620
(gdb) backtrace
#0  Fsignal (error_symbol=23761593, data=33773717) at eval.c:1620
#1  0x0100cd68 in xsignal (error_symbol=23761593, data=33773717) at eval.c:1722
#2  0x0100cfb7 in xsignal2 () at eval.c:1746
#3  0x01004620 in pure_write_error () at data.c:121
#4  0x0107e521 in Flength (sequence=35190653) at fns.c:185
#5  0x0107f1e0 in concat (nargs=1, args=0xd2ef10, target_type=Lisp_Cons, last_special=0) at fns.c:608
#6  0x0107f873 in Fcopy_sequence (arg=35190653) at fns.c:537
#7  0x0111ac12 in copy_properties (source=0x2190348, target=0x20932d8) at intervals.c:106
#8  0x0111be5f in graft_intervals_into_buffer (source=0x219096c, position=4420, length=1214, buffer=0x20a1a00, inherit=0) at intervals.c:1842
#9  0x0108f6fb in Ftranspose_regions (startr1=35256, endr1=44968, startr2=44968, endr2=45072, leave_markers=23697409) at editfns.c:4214
#10 0x0100c87b in Ffuncall (nargs=5, args=0xd2f590) at eval.c:3011
#11 0x0110f83f in Fbyte_code (bytestr=33420691, vector=33684868, maxdepth=40) at bytecode.c:679
#12 0x0100bdcd in Feval (form=33258701) at eval.c:2334
#13 0x0100e1da in internal_lisp_condition_case (var=23697409, bodyform=33258701, handlers=33258189) at eval.c:1426
#14 0x0110ffe0 in Fbyte_code (bytestr=33420707, vector=33684740, maxdepth=24) at bytecode.c:869
#15 0x0100c274 in funcall_lambda (fun=32895460, nargs=0, arg_vector=0xd2f924) at eval.c:3184
#16 0x0100c6c6 in Ffuncall (nargs=1, args=0xd2f920) at eval.c:3054
#17 0x0100df03 in apply1 (fn=33610257, arg=23697409) at eval.c:2738
#18 0x0110e61c in Fcall_interactively (function=33610257, record_flag=23697409, keys=23756804) at callint.c:406
#19 0x01057506 in Fcommand_execute (cmd=33610257, record_flag=23697409, keys=23697409, special=23697409) at keyboard.c:10013
#20 0x0105e2bd in command_loop_1 () at keyboard.c:1873
#21 0x0100aa24 in internal_condition_case (bfun=0x105df60 <command_loop_1>, handlers=23761545, hfun=0x1057f40 <cmd_error>) at eval.c:1481
#22 0x01051f6e in command_loop_2 () at keyboard.c:1329
#23 0x0100a949 in internal_catch (tag=23755777, func=0x1051f40 <command_loop_2>, arg=23697409) at eval.c:1222
#24 0x01051d7e in command_loop () at keyboard.c:1308
#25 0x01051e1f in recursive_edit_1 () at keyboard.c:1006
#26 0x01051f1c in Frecursive_edit () at keyboard.c:1067
#27 0x01002a75 in main (argc=3, argv=0x19a06e0) at emacs.c:1761
#28 0x010011e7 in _end__ ()
#29 0x01001238 in mainCRTStartup ()
#30 0xbff7b9e4 in _libwinspool_a_iname ()
#31 0xbff7b896 in _libwinspool_a_iname ()
#32 0xbff7a24f in _libwinspool_a_iname ()
(gdb) up 4
#4  0x0107e521 in Flength (sequence=35190653) at fns.c:185
(gdb) p sequence
$1 = 35190640
(gdb) xtype
Lisp_Int
(gdb) up 1
#5  0x0107f1e0 in concat (nargs=1, args=0xd2ef10, target_type=Lisp_Cons, last_special=0) at fns.c:608
(gdb) p argnum
$2 = 0
(gdb) p args[0]
$3 = 35190653
(gdb) xtype args[0]
Lisp_Cons
(gdb)

Re: transpose-regions

[Nick Roberts]

 > Martin sent me this additional info:
 > 
 > Hmmm ...
 > 
 > (gdb) xbacktrace
 > "transpose-regions" (0xc6c0)
 > "byte-code" (0x1fd43b3)
 > "m&d-drag-line-up" (0x1699801)
 > "call-interactively" (0x2002229)
 > (gdb) up 6
 > #6  0x0107f873 in Fcopy_sequence (arg=35173925) at fns.c:537
 > (gdb) pp arg
 > 
 > Program received signal SIGILL, Illegal instruction.
 > 0x00d2ec07 in ?? ()
 > (gdb) pp arg
 > (gdb) ppt
 > BUF PT: 7879 of 1..132090 GAP: 132090 SZ=2000

Doesn't this suggest that Emacs has been compiled with the with the wrong
options?

What were those options and what platform is this Emacs running on?


-- 
Nick                                           http://www.inet.net.nz/~nickrob

Re: transpose-regions

[Chong Yidong]

> I'm also puzzled by the
>
> #3  0x01004620 in pure_write_error () at data.c:121

Maybe gdb is just confused here; data.c:121 is indeed inside
wrong_type_argument, whereas pure_write_error starts on line 125.

Does the problem occur when you compile with no optimizations?

> I could send you the Elisp code I use to trigger this.  You'd have
> to play around with it a bit, though.

Is this the m&d-drag-line-up function that KFS already posted?  I've
been trying it out on various buffers, and have been unable to
reproduce it---is there a specific buffer you act on to produce the
error?

Re: transpose-regions

[martin rudalics]

 >  > (gdb) pp arg
 >  >
 >  > Program received signal SIGILL, Illegal instruction.
 >  > 0x00d2ec07 in ?? ()
 >  > (gdb) pp arg
 >  > (gdb) ppt
 >  > BUF PT: 7879 of 1..132090 GAP: 132090 SZ=2000
 >
 > Doesn't this suggest that Emacs has been compiled with the with the wrong
 > options?

Probably.

 >
 > What were those options and what platform is this Emacs running on?

In GNU Emacs 22.0.92.1 (i386-mingw-windows98.3000)
  of 2006-12-27 on MACHNO
X server distributor `Microsoft Corp.', version 4.90.3000
configured using `configure --with-gcc (3.4)'

Running on WindowsME with GNU gdb 5.2.1.

What do you suggest (apart from changing the OS)?

Re: transpose-regions

[martin rudalics]

[-- Attachment #1: Type: text/plain, Size: 841 bytes --]

> Does the problem occur when you compile with no optimizations?

I never use any options to compile.  What shall I use?

>>I could send you the Elisp code I use to trigger this.  You'd have
>>to play around with it a bit, though.
>
>
> Is this the m&d-drag-line-up function that KFS already posted?  I've
> been trying it out on various buffers, and have been unable to
> reproduce it---is there a specific buffer you act on to produce the
> error?

There's also a m&d-drag-line-down function and a pre-command hook.
Initially written while I worked with Emacs 20 (and transpose-regions
was somehow broken IIRC) and awfully patched a couple of times
afterwards.  I attach it.  To reproduce bind the drag-line functions to
a key and use the auto-repeat functionality of the keyboard (I use a
hyper key and the arrow keys for this purpose).


[-- Attachment #2: m&d.el --]
[-- Type: text/plain, Size: 33556 bytes --]

;;; m&d.el --- move'n drag support functions

;; Copyright (C) 2005 Martin Rudalics

;; Time-stamp: "2007-02-26 07:56:15 martin"
;; Author: Martin Rudalics <rudalics@gmx.at>
;; Keywords: sexps
;; Version: 0.1

;; m&d.el is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; m&d.el is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;;; Commentary:

;; move and drag support functions for GNU Emacs.

;;; Code:

;; _____________________________________________________________________________
;; 										
;;;				    Faces					
;; _____________________________________________________________________________
;; 										
(defgroup m&d nil
  "Move and drag."
  :version "22.1"
  :group 'faces)

(defcustom m&d-alert-delay 0.2
  "*Time m&d alerts when saving or replacing the m&d-region."
  :type '(choice number (const :tag "Don't alert" nil))
  :group 'm&d)

(defface m&d-alert
  '((((class color)) :background "Bisque")
    (t :bold t))
  "Face for highlighting m&d alerts."
  :group 'm&d)

(defface m&d-before
  '((((class color)) :foreground "Black" :background "Yellow")
    (t :bold t))
  "Face for highlighting delimiter before m&d-region."
  :group 'm&d)

(defface m&d-after
  '((((class color)) :foreground "Black" :background "Yellow")
    (t :bold t))
  "Face for highlighting delimiter after m&d-region."
  :group 'm&d)

(defface m&d-left
  '((((class color)) :background "Azure")
    (t :bold t))
  "Face for highlighting sexp left to m&d-region."
  :group 'm&d)

(defface m&d-right
  '((((class color)) :background "Azure")
    (t :bold t))
  "Face for highlighting sexp right to m&d-region."
  :group 'm&d)

(defface m&d-save
  '((t :underline t))
  "Face for highlighting sexp right to m&d-region."
  :group 'm&d)

;; _____________________________________________________________________________
;; 										
;;;				  Overlays					
;; _____________________________________________________________________________
;; 										

;; Observe: The following overlays are window-local
(defvar m&d-alert-overlay (make-overlay 1 1))
(overlay-put m&d-alert-overlay 'face 'm&d-alert)

(defvar m&d-before-overlay (make-overlay 1 1))
(overlay-put m&d-before-overlay 'face 'm&d-before)

(defvar m&d-after-overlay (make-overlay 1 1))
(overlay-put m&d-after-overlay 'face 'm&d-after)

(defvar m&d-left-overlay (make-overlay 1 1))
(overlay-put m&d-left-overlay 'face 'm&d-left)

(defvar m&d-right-overlay (make-overlay 1 1))
(overlay-put m&d-right-overlay 'face 'm&d-right)

;; _____________________________________________________________________________
;; 										
;;;				    Move					
;; _____________________________________________________________________________
;; 										
(defsubst m&d-syntax-class-after (&optional at)
  (let ((at (or at (point))))
    (syntax-class (syntax-after at))))

(defsubst m&d-syntax-class-before (&optional at)
  (let ((at (or at (point))))
    (syntax-class (syntax-after (1- at)))))

(defsubst m&d-escaped-p (&optional at)
  (save-excursion
    (when at (goto-char at))
    (while (and (eq (m&d-syntax-class-before) '9)
		(eq (m&d-syntax-class-before (1- (point))) '9))
      (backward-char 2))
    (eq (m&d-syntax-class-before) '9)))

(defun m&d-forward-sexp (&optional arg)
  "Like `forward-sexp' but within literal narrow to literal before.
With `point' before character with close paren syntax highlight
enclosing expression with `m&d-alert' face.  Don't generate an error in
any case."
  (interactive "p")
  (let ((at (point))
	(state (syntax-ppss)))
    (condition-case nil
	(if (or (nth 3 state) (nth 4 state))
	    (save-restriction
	      (narrow-to-region
	       (nth 8 state)
	       (condition-case nil
		   (save-excursion
		     (parse-partial-sexp
		      (point) (point-max) nil nil state 'syntax-table)
		     (point))
		 (error (point-max))))
	      (forward-sexp arg))
	  (forward-sexp arg))
      (error
       (move-overlay
	m&d-alert-overlay
	(condition-case nil
	    (save-excursion
	      (m&d-beginning-of-list)
	      (point))
	  (error (point-min)))
	at)
       (overlay-put m&d-alert-overlay 'window (selected-window))
       (ding)))))

(defun m&d-backward-sexp (&optional arg)
  "Like `backward-sexp' but within literal narrow to literal before.
With `point' after character with open paren syntax highlight enclosing
expression with `m&d-alert' face.  Don't generate an error in any case."
  (interactive "p")
  (let ((at (point))
	(state (syntax-ppss)))
    (condition-case nil
	(if (or (nth 3 state) (nth 4 state))
	    (save-restriction
	      (narrow-to-region
	       (nth 8 state)
	       (condition-case nil
		   (save-excursion
		     (parse-partial-sexp
		      (point) (point-max) nil nil state 'syntax-table)
		     (point))
		 (error (point-max))))
	      (backward-sexp arg))
	  (backward-sexp arg))
      (error
       (move-overlay
	m&d-alert-overlay
	at
	(condition-case nil
	    (save-excursion
	      (m&d-end-of-list)
	      (point))
	  (error (point-max))))
       (overlay-put m&d-alert-overlay 'window (selected-window))
       (ding)))))

(defun m&d-beginning-of-defun (&optional arg)
  "Like `beginning-of-defun' but don't generate an error."
  (interactive "p")
  (let ((at (point)))
    (condition-case nil
	(beginning-of-defun arg)
      (error (ding)))))

(defun m&d-end-of-defun (&optional arg)
  "Like `end-of-defun' but don't generate an error."
  (interactive "p")
  (let ((at (point)))
    (condition-case nil
	(end-of-defun arg)
      (error (ding)))))

(defun m&d-beginning-of-list (&optional arg)
  (interactive "p")
  (let ((at (point)))
    (condition-case nil
	(progn
	  (backward-up-list arg)
	  (forward-char))
      (error (ding)))))

(defun m&d-end-of-list (&optional arg)
  (interactive "p")
  (let ((at (point)))
    (condition-case nil
	(progn
	  (up-list arg)
	  (backward-char))
      (error (ding)))))

(defun m&d-forward-up (&optional arg)
  (interactive "p")
  (let ((at (point)))
    (condition-case nil
	(up-list arg)
      (error (ding)))))

(defun m&d-backward-up (&optional arg)
  (interactive "p")
  (let ((at (point)))
    (condition-case nil
	(backward-up-list arg)
      (error (ding)))))

(defun m&d-home ()
  "In first call move point to beginning of line, in subsequent calls to
beginning of buffer."
  (interactive)
  (if (eq last-command 'm&d-home)
      (goto-char (point-min))
    (beginning-of-line)))

(defun m&d-end ()
  "In first call move point to end of line, in subsequent calls to end of
buffer."
  (interactive)
  (if (eq last-command 'm&d-end)
      (goto-char (point-max))
    (end-of-line)))

;; _____________________________________________________________________________
;; 										
;;;				    Mark					
;; _____________________________________________________________________________
;; 										
(defvar m&d-mark-history () ; remove duplicates, eventually
  "History for actual `m&d-mark-sexp', reset by `m&d-pre-command'.
Each entry is a cons pair whose car is point and whose cdr mark.")

(defvar m&d-mark nil)

(defun m&d-ensure-mark ()
  (when mark-active (setq deactivate-mark nil)))

(defun m&d-mark-highlight (&optional from to)
  "Highlight various parts of m&d-region."
  (unless (memq major-mode '(sobar-mode sonderbar-mode))
    (let ((from (or from
		    (and mark-active (min (point) (mark)))
		    (point)))
	  (to (or to
		  (and mark-active (max (point) (mark)))
		  (point)))
	  (window (selected-window))
	  before after beg end)
      (setq m&d-mark t)
      (condition-case nil
	  (save-excursion
	    (condition-case nil
		(progn
		  (goto-char from)
		  (backward-up-list)
		  (setq before (point))
		  (move-overlay m&d-before-overlay before (1+ before))
		  (overlay-put m&d-before-overlay 'window window))
	      (error nil))
	    (condition-case nil
		(progn
		  (goto-char to)
		  (up-list)
		  (setq after (point))
		  (move-overlay m&d-after-overlay (1- after) after)
		  (overlay-put m&d-after-overlay 'window window))
	      (error nil))
	    (condition-case nil
		(progn
		  (goto-char from)
		  (backward-sexp)
		  (setq beg (point))
		  (forward-sexp)
		  (setq end (point))
		  (when (and (< beg end) (<= end from))
		    (move-overlay m&d-left-overlay beg end)
		    (overlay-put m&d-left-overlay 'window window)))
	      (error nil))
	    (condition-case nil
		(progn
		  (goto-char to)
		  (forward-sexp)
		  (setq end (point))
		  (backward-sexp)
		  (setq beg (point))
		  (when (and (<= to beg) (< beg end))
		    (move-overlay m&d-right-overlay beg end)
		    (overlay-put m&d-right-overlay 'window window)))
	      (error nil)))
	(error nil)))))

(defun m&d-exchange-point-and-mark ()
  "Like `exchange-point-and-mark' but highlight marked region."
  (interactive)
  (exchange-point-and-mark)
  (m&d-mark-highlight (min (point) (mark)) (max (point) (mark))))


(defun m&d-mark-sexp ()
  "Enlarge m&d-region.
Pushes previous values of `point' and `mark' on `m&d-mark-history'."
  (interactive)
  (if mark-active
      (let* ((state (syntax-ppss))
	     (beg (min (mark) (point)))
	     (end (max (mark) (point)))
	     (point-is-beg (= beg (point)))
	     (point-mark (cons (point) (mark)))
	     from to before-after)
	(cond
	 ((eq (m&d-syntax-class-before beg) '6)
	  (save-excursion
	    (goto-char beg)
	    (skip-syntax-backward "'")
	    (setq from (point)))
	  (save-excursion
	    (goto-char end)
	    (skip-syntax-forward "'")
	    (setq to (point)))
	  (setq before-after t))
	 ((or (nth 3 state) (nth 4 state))
	  ;; Within string or comment, mark entire string or comment.
	  (setq from (nth 8 state))
	  (setq to (save-excursion
		     (condition-case nil
			 (progn
			   (parse-partial-sexp
			    (point) (point-max) nil nil state 'syntax-table)
			   (point))
		       (error nil))))
	  (cond
	   ((nth 3 state)
	    (setq before-after t))
	   ((and from to (nth 4 state)
		 (or (> from beg) (< to end)
		     (and (= from beg) (= to end))))
	    ;; Failed to expand comment.
	    (save-excursion
	      (goto-char from)
	      (forward-comment (- (buffer-size)))
	      (setq from (point)))
	    (save-excursion
	      (goto-char to)
	      (forward-comment (buffer-size))
	      (setq to (point))))))
	 ((let ((class-first (syntax-class (syntax-after beg)))
		(class-last (syntax-class (syntax-after (1- end))))
		from-white to-white)
	    ;; Before or after a comment: Mark entire sequence of comments
	    ;; before and after the present.  `from-white' and `to-white'
	    ;; shall guarantee that the marked region encompasses entire
	    ;; marked region before applying the present step.
	    (and (or (memq class-first '(11 14))
		     (memq class-last '(12 14)))
		 (condition-case nil
		     (progn
		       ;; The following is weird but I do want to distinguish
		       ;; newlines that terminate comments from newlines that
		       ;; don't.  Hence I skip all comments before or after
		       ;; point first.
		       (save-excursion
			 (setq from beg)
			 (while (forward-comment -1)
			   (setq from (point)))
			 (setq from-white (point)))
		       (save-excursion
			 (setq to end)
			 (while (forward-comment 1)
			   (setq to (point)))
			 (setq to-white (point)))
		       ;; Something should have been enlarged here.
		       (unless (and (<= from beg) (>= to end))
			 ;; Symmetrically include previously marked whitespace.
			 (setq from from-white)
			 (setq to to-white))
		       (or (< from beg) (> to end)))
		   (error nil)))))
	 ((nth 1 state)
	  (setq from
		(save-excursion
		  (goto-char (nth 1 state))
		  (point)))
	  (condition-case nil
	      (progn
		(parse-partial-sexp
		 (point) (point-max) (1- (nth 0 state)) nil state)
		(setq to (point))
		(setq before-after t))
	    (error nil)))
	 (t
	  (setq from (point-min))
	  (setq to (point-max))
	  (m&d-mark-highlight from to)))
	(if (and from to)
	    (progn
	      (setq m&d-mark-history (cons point-mark m&d-mark-history))
	      (when before-after (m&d-mark-highlight from to))
	      (set-mark (if point-is-beg to from))
	      (goto-char (if point-is-beg from to)))
	  ;; This shouldn't happen.
	  (message "Can't mark") (ding)))
    ;; Region inactive, move to some significant position:
    (let* ((at (save-excursion
		 (skip-chars-forward " \t") (point)))
	   (class (syntax-class (syntax-after at)))
	   (point-mark (cons (point) nil))
	   from to before-after)
      (save-excursion
	(goto-char at)
	(cond
	 ((memq class '(2 3 8 9 10 13))
	  ;; Word, symbol, open paren, and some others.
	  (save-excursion
	    (condition-case nil
		(backward-sexp)
	      (error nil))
	    (skip-syntax-forward "'")
	    (skip-syntax-backward "/\\")
	    (setq from (point)))
	  (forward-sexp)
	  (backward-prefix-chars)
	  (setq to (point))
	  (setq before-after 'check))
	 ((memq class '(4 6))
	  ;; Expression prefix.
	  (save-excursion
	    (skip-syntax-backward "'")
	    (setq from (point)))
	  (forward-sexp)
	  (setq to (point))
	  (setq before-after 'check))
	 ((eq class '5)
	  ;; Close paren.
	  (forward-char)
	  (condition-case nil
	      (progn
		(backward-sexp)
		(setq from (point))
		(forward-sexp)
		(backward-prefix-chars)
		(setq to (point))
		(setq before-after 'check))
	    (error nil)))
	 ((memq class '(7 15))
	  (let ((state (syntax-ppss)))
	    (if (nth 3 state)
		;; Within string.
		(save-restriction
		  (narrow-to-region
		   (nth 8 state)
		   (condition-case nil
		       (save-excursion
			 (parse-partial-sexp (point) (point-max) nil nil state 'syntax-table)
			 (point))
		     (error (point-max))))
		  (forward-char)
		  (condition-case nil
		      (progn
			(backward-sexp)
			(setq from (point))
			(forward-sexp)
			(backward-prefix-chars)
			(setq to (point))
			(when (and (= from (point-min)) (= to (point-max)))
			  (setq before-after t)))
		    (error nil)))
	      ;; Before string
	      (forward-sexp)
	      (backward-prefix-chars)
	      (setq to (point))
	      (condition-case nil
		  (backward-sexp)
		(error nil))
	      (skip-syntax-forward "'")
	      (setq from (point))
	      (setq before-after t))))
	 ((and (memq class '(11 12 14))
	       ;; Around comment, we wrap this in an `and' to give the
	       ;; subsequent steps a chance.
	       (let ((state (syntax-ppss)))
		 (cond
		  ((nth 4 state)
		   ;; Within comment.
		   (setq from (nth 8 state))
		   (condition-case nil
		       (save-excursion
			 (parse-partial-sexp
			  (point) (point-max) nil nil state 'syntax-table)
			 (setq to (point)))
		     (error nil)))
		  ((memq class '(11 14))
		   ;; Probably before comment.
		   (setq from (point))
		   (condition-case nil
		       (save-excursion
			 (forward-comment 1)
			 (setq to (point)))
		     (error nil)))))))
	 ((eq class '1)
	  ;; Mark punctuation syntax.
	  (save-excursion
	    (skip-syntax-forward ".")
	    (setq to (point)))
	  (skip-syntax-backward ".")
	  (setq from (point)))
	 ((eq (char-after) ?\n)
	  ;; Mark whitespace around newline, mark nothing at end of not
	  ;; newline terminated buffer.
	  (save-excursion
	    (when (forward-comment -1)
	      (forward-comment 1))
	    (setq from (point)))
	  (save-excursion
	    (when (forward-comment 1)
	      (forward-comment -1))
	    (setq to (point))))))
      (if (and from to)
	  (progn
	    (when before-after
	      (if (eq before-after 'check)
		  (let ((state (syntax-ppss))
			narrow-from narrow-to)
		    (if (or (nth 3 state) (nth 4 state))
			(save-excursion
			  (setq narrow-from (nth 8 state))
			  (setq narrow-to
				(condition-case nil
				    (progn
				      (parse-partial-sexp
				       (point) (point-max)
				       nil nil state 'syntax-table)
				      (point))
				  (error nil)))
			  (when (and narrow-from narrow-to)
			    (save-restriction
			      (narrow-to-region narrow-from narrow-to)
			      (m&d-mark-highlight from to))))
		      (m&d-mark-highlight from to)))
		(m&d-mark-highlight from to)))
	    (setq m&d-mark-history (cons point-mark m&d-mark-history))
	    (push-mark to t t)
	    (goto-char from))
	(message "Can't mark") (ding)))))

(defun m&d-mark-undo ()
  "Pop `m&d-mark-history'."
  (interactive)
  (if m&d-mark-history
      (let ((mark (cdar m&d-mark-history)))
	(when mark (set-mark mark))
	(setq mark-active mark)
	(goto-char (caar m&d-mark-history))
	(when mark
	  (m&d-mark-highlight (min (point) (mark)) (max (point) (mark))))
	(setq m&d-mark-history (cdr m&d-mark-history)))
    (message "No undo information")
    (ding)))

;; Maybe this should become a ring.
(defvar m&d-saved-region nil
  "Region saved by last `m&d-save-region'.")

(defun m&d-alert-region (beg end)
  "Temporarily highlight region with `m&d-alert' face."
  (when m&d-alert-delay
    (setq mark-active nil)
    (let ((overlay (make-overlay beg end)))
      (overlay-put overlay 'face 'm&d-alert)
      (overlay-put overlay 'priority 100000)
      (delete-overlay overlay))
      (sit-for m&d-alert-delay)
    (setq mark-active t)))

(defun m&d-save-region (beg end)
  "Save m&d-region into `m&d-saved-region'.
Does not modify `m&d-mark-undo'."
  (interactive "r")
  (setq m&d-saved-region (buffer-substring-no-properties beg end))
  (m&d-alert-region beg end)
  (m&d-mark-highlight beg end))

(defun m&d-replace-region (beg end)
  "Replace m&d-region by `m&d-saved-region'.
Clears `m&d-mark-undo'."
  (interactive "r")
  (if m&d-saved-region
      (let ((to (+ beg (length m&d-saved-region))))
	(delete-region beg end)
	(insert m&d-saved-region)
	(goto-char beg)
	(set-mark to)
	(setq deactivate-mark nil)
	(m&d-alert-region beg to)
	(m&d-mark-highlight beg to))
    (error "Nothing saved")))

(defun m&d-kill-region (beg end)
  (interactive "r")
  (let (from to left right)
    (if (and (save-excursion
	       (goto-char beg)
	       (skip-chars-backward " \t")
	       (cond
		((bolp) (setq from (point)))
		((bobp) nil) 
		(t
		 (setq from beg)
		 (setq left t))))
	     (save-excursion
	       (goto-char end)
	       (skip-chars-forward " \t")
	       (cond
		((eolp) (setq to (point)))
		((eobp) nil)
		(t
		 (setq to end)
		 (setq right t)))))
	(cond
	 ((and left right)
	  (delete-region end to)
	  (kill-region beg end)
	  (delete-region from beg)
	  (fixup-whitespace))
	 (left
	  ;; Remove everything from end till first non-whitespace.
	  (goto-char end)
	  (skip-chars-forward " \t\n\f")
	  (delete-region end (point))
	  (kill-region beg end)
	  (delete-region from beg))
	 (right
	  (delete-region end to)
	  (kill-region beg end)
	  (goto-char beg)
	  (skip-chars-backward " \t\n\f")
	  (if (nth 4 (syntax-ppss))
	      (delete-region (1+ (point)) beg)
	    (delete-region (point) beg)))
	 (t
	  (delete-region end (if (= to (point-max)) to (1+ to)))
	  (kill-region beg end)
	  (delete-region from beg)))
      (kill-region beg end))))

(defun m&d-copy ()
  "Copy region or line and point and activate it."
  (interactive)
  (let ((copied-string
         (if mark-active
             (buffer-substring
              (min (mark) (point)) (max (mark) (point)))
           (buffer-substring
	    (line-beginning-position) (line-beginning-position 2))))) 
    (goto-char (if mark-active
                   (max (mark) (point))
                 (line-beginning-position 2)))
    (insert copied-string)
    (set-mark (point))
    (goto-char (- (point) (length copied-string)))
    (setq deactivate-mark nil)
    (setq mark-active t)))

;; _____________________________________________________________________________
;; 										
;;;				    Drag					
;; _____________________________________________________________________________
;; 										
(defun m&d-drag-char-right ()
  "If region is active drag it right by one char else drag char at point right."
  (interactive)
  (cond
   (mark-active
    (let* ((beg (min (mark) (point)))
	   (end (max (mark) (point)))
	   (mark-beg (1+ (- (mark) beg)))
	   (point-beg (1+ (- (point) beg))))
      (if (= end (point-max))
	  (progn (message "Can't drag") (ding))
	(transpose-regions beg end end (1+ end))
	(set-mark (+ mark-beg beg))
	(setq deactivate-mark nil)
	(goto-char (+ point-beg beg)))))
   ((or (eobp) (= (point) (1- (point-max))))
    (m&d-ensure-mark)
    (message "Can't drag") (ding))
   (t (let ((to (1+ (point))))
	(transpose-regions (point) to to (1+ to))
	(goto-char to)))))

(defun m&d-drag-char-left ()
  "If region is active drag it left by one char else drag char at point left."
  (interactive)
  (cond
   (mark-active
    (let* ((beg (min (mark) (point)))
	   (end (max (mark) (point)))
	   (mark-beg (- (mark) beg 1))
	   (point-beg (- (point) beg 1)))
      (if (= beg (point-min))
	  (progn (message "Can't drag") (ding))
	(transpose-regions (1- beg) beg beg end)
	(set-mark (+ mark-beg beg))
	(setq deactivate-mark nil)
	(goto-char (+ point-beg beg)))))
   ((or (bobp) (eobp))
    (m&d-ensure-mark)
    (message "Can't drag") (ding))
   (t (let ((to (1- (point))))
	(transpose-regions to (point) (point) (1+ (point)))
	(goto-char to)))))

(defun m&d-drag-line-down (&optional beg end)
  "Drag region down by one line. Region defaults to current line.
Region is always rounded up to whole lines."
  (interactive)
  (let* ((beg (save-excursion
		(goto-char
		 (or beg (and mark-active (min (point) (mark))) (point)))
		(line-beginning-position)))
	 (end (save-excursion
		(goto-char
		 (or end (and mark-active (max (point) (mark)))
		     (line-beginning-position 2)))
		(if (bolp) (point) (line-beginning-position 2))))
	 (point-beg (and (<= beg (point)) (<= (point) end)
			 (- (point) beg)))
	 (mark-beg (and mark-active (<= beg (mark)) (<= (mark) end)
			(- (mark) beg)))
	 (to (save-excursion
	       (goto-char end)
	       (line-beginning-position 2)))
	 (recenter (when (= beg (window-start))
		     (1+ (count-lines beg end)))))
    (unless (and (>= (point) beg) (<= (point) end))
      ;; `point' should be within dragged region.
      (goto-char end))
;;;     (condition-case nil
	;; Wrapped in condition-case until we find out why `transpose-regions'
	;; is broken.
	(if (> to end)
	    (progn
	      (if (save-excursion (goto-char to) (not (bolp)))
		  ;; Pobably at eob.
		  (progn
		    (when (= (point) end) (backward-char))
		    (transpose-regions beg (1- end) end to))
		(transpose-regions beg end end to))
	      ;; Don't push mark.
	      (when mark-beg
		(set-mark (+ mark-beg beg (- to end)))
		(setq deactivate-mark nil))
	      (when point-beg
		(goto-char (+ point-beg beg (- to end))))
	      (when recenter
		(recenter recenter)))
	  (m&d-ensure-mark)
	  (message "Can't drag")
	  (ding))
;;;       (error (m&d-ensure-mark)))))
	))

(defun m&d-drag-line-up (&optional beg end)
  "Drag region up by one line. Region defaults to current line.
Region is always rounded up to whole lines."
  (interactive)
  (let* ((beg (save-excursion
		(goto-char
		 (or beg (and mark-active (min (point) (mark))) (point)))
		(line-beginning-position)))
	 (end (save-excursion
		(goto-char
		 (or end (and mark-active (max (point) (mark)))
		     (line-beginning-position 2)))
		(if (bolp) (point) (line-beginning-position 2))))
	 (point-beg (and (<= beg (point)) (<= (point) end)
			 (- (point) beg)))
	 (mark-beg (and mark-active (<= beg (mark)) (<= (mark) end)
			(- (mark) beg)))
	 (from (save-excursion
		 (goto-char beg)
		 (line-beginning-position 0)))
	 (recenter (when (= from (window-start))
		     (count-lines beg end))))
;;;     (condition-case nil
	;; Wrapped in condition-case until we find out why `transpose-regions'
	;; is broken.
	(if (> beg from)
	    (progn
	      (if (save-excursion (goto-char end) (not (bolp)))
		  ;; Probably at eob.
		  (transpose-regions from (1- beg) beg end)
		(transpose-regions from beg beg end))
	      (when mark-beg
		(set-mark (+ mark-beg from))
		(setq deactivate-mark nil))
	      (when point-beg
		(goto-char (+ point-beg from)))
	      (when recenter
		(recenter recenter)))
	  (m&d-ensure-mark)
	  (message "Can't drag")
	  (ding))
;;;       (error (m&d-ensure-mark)))))
	))
(defun m&d-drag-sexp-right (&optional beg end)
  "Drag region right by one sexp. Region defaults to sexp at point.
When the mark is active, this function may move point and set mark to
make the dragged region suitable for further dragging."
  (interactive)
  (let* ((end (or end
		  (and mark-active
		       (save-excursion
			 (goto-char (max (point) (mark)))
			 (skip-chars-backward " \n\t\f")
			 ;; The following might not skip any more newlines:
			 (skip-syntax-backward " .") (point)))
		  (save-excursion
		    (forward-sexp) (backward-prefix-chars) (point))))
	 (beg (or beg
		  (and mark-active
		       (save-excursion
			 (goto-char (min (point) (mark)))
			 (skip-chars-forward " \n\t\f")
			 ;; The following might not skip any more newlines:
			 (skip-syntax-forward " .") (point)))
		  (save-excursion (goto-char end) (backward-sexp) (point))))
	 (point-beg (and (<= beg (point)) (<= (point) end)
			 (- (point) beg)))
	 (mark-beg (and mark-active (<= beg (mark)) (<= (mark) end)
			(- (mark) beg)))
	 (to (save-excursion
	       (goto-char end)
	       (condition-case nil
		   (save-excursion
		     (forward-sexp) (backward-prefix-chars) (point))
		 (error nil))))
	 (from (when to
		 (save-excursion
		   (goto-char to)
		   (condition-case nil
		       (save-excursion
			 (backward-sexp)
			 (point))
		     (error nil)))))
	 point-beg mark-beg)
    (when mark-active
      (cond
       ((< (mark) beg) (set-mark beg))
       ((< end (mark)) (set-mark end)))
      (setq mark-beg (- (mark) beg)))
    (setq point-beg
	  (cond
	   ((< (point) beg) 0)
	   ((< end (point)) (- end beg))
	   (t (- (point) beg))))
    (if (and from to (> to from) (>= from end))
	(progn
	  (transpose-regions beg end from to)
	  (when mark-beg
	    (set-mark (+ mark-beg beg (- to end)))
	    (setq deactivate-mark nil))
	  (goto-char (+ point-beg beg (- to end)))
	  (when mark-active
	    (m&d-mark-highlight (min (point) (mark)) (max (point) (mark)))))
      (when mark-active
	(setq deactivate-mark nil)
	(m&d-mark-highlight (min (point) (mark)) (max (point) (mark))))
      (message "Can't drag")
      (ding))))

(defun m&d-drag-sexp-left (&optional beg end)
  "Drag region left by one sexp. Region defaults to sexp at point.
When the mark is active, this function may move point and set mark to
make the dragged region suitable for further dragging."
  (interactive)
  (let* ((end (or end
		  (and mark-active
		       (save-excursion
			 (goto-char (max (point) (mark)))
			 (skip-chars-backward " \n\t\f")
			 ;; The following might not skip any more newlines:
			 (skip-syntax-backward " .") (point)))
		  (save-excursion
		    (forward-sexp) (backward-prefix-chars) (point))))
	 (beg (or beg
		  (and mark-active
		       (save-excursion
			 (goto-char (min (point) (mark)))
			 (skip-chars-forward " \n\t\f")
			 ;; The following might not skip any more newlines:
			 (skip-syntax-forward " .") (point)))
		  (save-excursion (goto-char end) (backward-sexp) (point))))
	 (from (save-excursion
		 (goto-char beg)
		 (condition-case nil
		     (save-excursion
		       (backward-sexp) (point))
		   (error nil))))
	 (to (when from
	       (save-excursion
		 (goto-char from)
		 (condition-case nil
		     (save-excursion
		       (forward-sexp) (backward-prefix-chars) (point))
		   (error nil)))))
	 point-beg mark-beg)
    (when mark-active
      (cond
       ((< (mark) beg) (set-mark beg))
       ((< end (mark)) (set-mark end)))
      (setq mark-beg (- (mark) beg)))
    (setq point-beg
	  (cond
	   ((< (point) beg) 0)
	   ((< end (point)) (- end beg))
	   (t (- (point) beg))))
    (if (and from to (> to from) (<= to beg))
	(progn
	  (transpose-regions from to beg end)
	  (when mark-beg
	    (set-mark (+ mark-beg from))
	    (setq deactivate-mark nil))
	  (goto-char (+ point-beg from))
	  (when mark-active
	    (m&d-mark-highlight (min (point) (mark)) (max (point) (mark)))))
      (when mark-active
	(setq deactivate-mark nil)
	(m&d-mark-highlight (min (point) (mark)) (max (point) (mark))))
      (message "Can't drag")
      (ding))))

;; _____________________________________________________________________________
;; 										
;;;				Key bindings					
;; _____________________________________________________________________________
;; 										
(global-set-key [(control right)] 'm&d-forward-sexp)
(global-set-key [(control left)] 'm&d-backward-sexp)
(global-set-key [(control up)] 'm&d-beginning-of-defun)
(global-set-key [(control down)] 'm&d-end-of-defun)

(global-set-key [(control meta left)] 'm&d-beginning-of-list)
(global-set-key [(control meta right)] 'm&d-end-of-list)
(global-set-key [(control meta up)] 'm&d-backward-up)
(global-set-key [(control meta down)] 'm&d-forward-up)

(global-set-key [home] 'm&d-home)
(global-set-key [end] 'm&d-end)

(define-key text-mode-map [(control right)] 'forward-word)
(define-key text-mode-map [(control left)] 'backward-word)
(define-key text-mode-map [(control down)] 'forward-paragraph)
(define-key text-mode-map [(control up)] 'backward-paragraph)

(define-key text-mode-map [(control meta right)] 'forward-sentence)
(define-key text-mode-map [(control meta left)] 'backward-sentence)

(global-set-key [capslock] 'm&d-mark-sexp)
(global-set-key [(meta capslock)] 'm&d-exchange-point-and-mark)
(global-set-key [(shift capslock)] 'm&d-mark-undo)
(global-set-key [(hyper capslock)] 'm&d-save-region)
(global-set-key [(hyper shift capslock)] 'm&d-kill-region)
(global-set-key [(hyper meta capslock)] 'm&d-replace-region)

(global-set-key [(hyper control left)] 'm&d-drag-sexp-left)
(global-set-key [(hyper control right)] 'm&d-drag-sexp-right)
(global-set-key [(hyper up)] 'm&d-drag-line-up)
(global-set-key [(hyper down)] 'm&d-drag-line-down)
(global-set-key [(hyper left)] 'm&d-drag-char-left)
(global-set-key [(hyper right)] 'm&d-drag-char-right)

(global-set-key [(kp-enter)] 'm&d-copy)

;; _____________________________________________________________________________
;; 										
;;;				 Pre-command					
;; _____________________________________________________________________________
;; 										
(dolist (cmd
 '(forward-char backward-char
   next-line previous-line
   forward-word backward-word
   end-of-line beginning-of-line
   move-end-of-line move-beginning-of-line
   end-of-buffer beginning-of-buffer
   scroll-up scroll-down
   up-list down-list backward-up-list
   end-of-defun beginning-of-defun
   m&d-forward-sexp m&d-backward-sexp
   m&d-beginning-of-defun m&d-end-of-defun
   m&d-beginning-of-list m&d-end-of-list
   m&d-forward-up m&d-backward-up
   m&d-home m&d-end
   forward-sexp backward-sexp
   forward-list backward-list
   forward-sentence backward-sentence
   forward-paragraph backward-paragraph))
  (put cmd 'm&d 'move))

(dolist (cmd
 '(m&d-mark-sexp m&d-mark-undo m&d-mark-save m&d-exchange-point-and-mark))
  (put cmd 'm&d 'save))

;; REDO completely ...... 
(defun m&d-pre-command ()
  (condition-case nil
      ;; We need a condition case to avoid that things like imenu mess up things.
      (progn
	(when (and m&d-mark-history (not (eq (get this-command 'm&d) 'save)))
	  ;; Remove mark history.
	  (setq m&d-mark-history nil))
	;; Delete overlays, make this conditional - they can be reused.
	(unless (memq major-mode '(sobar-mode sonderbar-mode))
	  (dolist (overlay (list m&d-alert-overlay m&d-before-overlay m&d-after-overlay
				 m&d-left-overlay m&d-right-overlay
				 ;; Delete show-paren's overlays to avoid flickering.
				 show-paren-overlay show-paren-overlay-1))
	    (when (overlayp overlay)
	      (delete-overlay overlay)))
	  ;; Shifted movement.
	  (if (not (eq (get this-command 'm&d) 'move))
	      (setq m&d-mark nil)
	    (if (memq 'shift (event-modifiers (aref (this-single-command-raw-keys) 0)))
		(progn
		  (unless mark-active
		    (push-mark-command nil t))
		  (if m&d-mark
		      (add-hook 'post-command-hook 'm&d-mark-highlight)
		    (remove-hook 'post-command-hook 'm&d-mark-highlight)))
	      (unless (eq (get last-command 'm&d) 'move)
		(push-mark-command nil t))
	      (remove-hook 'post-command-hook 'm&d-mark-highlight)
	      (setq mark-active nil)
	      (setq deactivate-mark t)))))
    (error nil)))

(add-hook 'pre-command-hook 'm&d-pre-command)

(provide 'm&d)
;;; up / down have to conceptually do: (1) Check whether the region is balanced,
;;; and if it is not try to extract the balanced part, remove that, adjust, (2)
;;; do the move, and (3) check whether the region is balanced again.

;;; m&d.el ends here

;; (1) m&d-mark-highlight can be wrong after shifted movement, use a stronger
;;     criterium.

;; (2) backward-prefix-chars should not skip "'" after a `foo'.  Hence, within
;;     literals we should check whether these are used for this particular
;;     thing.

;; (3) push-mark doesn't work correctly yet.

;; (4) shifted forward-/backward-char within string is awfully slow

(defun m&d-mark-dwim ()
  (interactive)
  (cond
   ((and (eq last-command this-command) mark-ring)
    (pop-to-mark-command))
   ((mark t)
    (exchange-point-and-mark))
   (t
    (let ((mark (marker-position (point-marker))))
      (push-mark nil t))))
  (setq deactivate-mark t))

(global-set-key [(hyper .)] 'm&d-mark-dwim)

;;; Debugger entered--Lisp error: (wrong-type-argument listp 4159323)
;;;   transpose-regions(306379 306408 306408 306504)
;;;   m&d-drag-line-up()
;;;   call-interactively(m&d-drag-line-up)

[-- Attachment #3: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Emacs-devel mailing list
Emacs-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/emacs-devel

Re: transpose-regions

[David Kastrup]

martin rudalics <rudalics@gmx.at> writes:

> In GNU Emacs 22.0.92.1 (i386-mingw-windows98.3000)
>  of 2006-12-27 on MACHNO
^^^^^^^^^^^^^^^^^^^^^^^^^^
Old!

> X server distributor `Microsoft Corp.', version 4.90.3000
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Interesting.

> configured using `configure --with-gcc (3.4)'
                                         ^^^^^
Not quite new, either.

> Running on WindowsME with GNU gdb 5.2.1.
>
> What do you suggest (apart from changing the OS)?

Updating your version of Emacs and/or gcc.  You might try one of the
precompiled versions anonuced on this list.

-- 
David Kastrup, Kriemhildstr. 15, 44793 Bochum

Re: transpose-regions

[Andreas Schwab]

Chong Yidong <cyd@stupidchicken.com> writes:

> Flength was called with sequence=35193781; how did it mutate into
> 35193768?

Perhaps the compiler didn't tell the debugger that the location that held
the value of sequence no longer does so.

Andreas.

-- 
Andreas Schwab, SuSE Labs, schwab@suse.de
SuSE Linux Products GmbH, Maxfeldstraße 5, 90409 Nürnberg, Germany
PGP key fingerprint = 58CA 54C7 6D53 942B 1756  01D3 44D5 214B 8276 4ED5
"And now for something completely different."

Re: transpose-regions

[martin rudalics]

>>In GNU Emacs 22.0.92.1 (i386-mingw-windows98.3000)
>> of 2006-12-27 on MACHNO
> 
> ^^^^^^^^^^^^^^^^^^^^^^^^^^
> Old!

It's my last bootstrap.  My later compilations don't work with gdb
(for some reason).  A bootstrap takes two hours here.

>>X server distributor `Microsoft Corp.', version 4.90.3000
> 
> ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
> 
> Interesting.
> 
> 
>>configured using `configure --with-gcc (3.4)'
> 
>                                          ^^^^^
> Not quite new, either.

I'm glad I was able to install this on my machine.

>>Running on WindowsME with GNU gdb 5.2.1.
>>
>>What do you suggest (apart from changing the OS)?
> 
> 
> Updating your version of Emacs and/or gcc.  You might try one of the
> precompiled versions anonuced on this list.

When I did that two years ago I was left without a menubar, not that
I use menus frequently ... Precompiled versions are for XP.

Re: transpose-regions

[martin rudalics]

> Is this the m&d-drag-line-up function that KFS already posted?  I've
> been trying it out on various buffers, and have been unable to
> reproduce it---is there a specific buffer you act on to produce the
> error?

Sorry, forgot to answer the last question: Use an arbitrary Elisp buffer.
However, the bug _never_ shows up the first time you call this.  Sometimes
I have to call it twenty and more times in sequence with no other actions
in between.

Re: transpose-regions

[Chong Yidong]

I managed to reproduce the problem.  My backtrace is a little
different, but it makes sense; probably Martin's debugger is confused,
maybe due to being out of sync with his sources.

Upon setting a breakpoint at wrong_type_argument, I obtained the
following backtrace:

(gdb) bt
#0  wrong_type_argument (predicate=138004297, value=142379640) at data.c:118
#1  0x081bb353 in Flength (sequence=142379640) at fns.c:180
#2  0x081bc272 in concat (nargs=1, args=0xbfec7350, target_type=Lisp_Cons, 
    last_special=0) at fns.c:610
#3  0x081bc0ab in Fcopy_sequence (arg=142379653) at fns.c:539
#4  0x08208837 in copy_properties (source=0x87cc888, target=0x87cc7e0)
    at intervals.c:110
#5  0x0820b9cf in graft_intervals_into_buffer (source=0x87cc888, 
    position=13049, length=45, buffer=0x8398540, inherit=0) at intervals.c:1846
....
(gdb) f 2
#2  0x081bc272 in concat (nargs=1, args=0xbfec7350, target_type=Lisp_Cons, 
    last_special=0) at fns.c:610
610           len = XFASTINT (Flength (this));
(gdb) p this
$1 = 142379653
(gdb) xtype
Lisp_Cons
(gdb) xcons
$2 = (struct Lisp_Cons *) 0x87c8a80
{
  car = 0x8234763, 
  u = {
    cdr = 0x87c8a78, 
    chain = 0x87c8a78
  }
}
(gdb) p 0x8234763
$3 = 136529763
(gdb) xtype
Lisp_String
(gdb) xstring
$4 = (struct Lisp_String *) 0x8234760
"DEAD"
(gdb) p Vdead
$5 = 136529763

The problem seems to be that a cons cell that has already been
garbage-collected is being passed to Fcopy_sequence during
copy_properties(), in intervals.c:106.  Where did this cons cell come
from?

  target->plist = Fcopy_sequence (source->plist);

Is the garbage collector somehow failing to account for cons cells
assigned to interval plists?

Re: transpose-regions

[martin rudalics]

 > I managed to reproduce the problem.  My backtrace is a little
 > different, but it makes sense; probably Martin's debugger is confused,
 > maybe due to being out of sync with his sources.
 >
 > Upon setting a breakpoint at wrong_type_argument, I obtained the
 > following backtrace:
[...]
 > (gdb) xstring
 > $4 = (struct Lisp_String *) 0x8234760
 > "DEAD"
 > (gdb) p Vdead
 > $5 = 136529763

With the breakpoint at data.c:118 I can confirm this.  Apparently,
breaking at Fsignal confuses my debugger.

Re: transpose-regions

[Andreas Schwab]

Chong Yidong <cyd@stupidchicken.com> writes:

> The problem seems to be that a cons cell that has already been
> garbage-collected is being passed to Fcopy_sequence during
> copy_properties(), in intervals.c:106.  Where did this cons cell come
> from?
>
>   target->plist = Fcopy_sequence (source->plist);
>
> Is the garbage collector somehow failing to account for cons cells
> assigned to interval plists?

Unlikely, what would be a too obvious bug to remain unnoticed until now
(and mark_interval indeed does mark the plist).  More likely that the
whole interval is not being marked in the first place.  The function uses
the local variables tmp_interval[12] that are copies of the buffer
intervals, perhaps they need to be protected from GC?

Andreas.

-- 
Andreas Schwab, SuSE Labs, schwab@suse.de
SuSE Linux Products GmbH, Maxfeldstraße 5, 90409 Nürnberg, Germany
PGP key fingerprint = 58CA 54C7 6D53 942B 1756  01D3 44D5 214B 8276 4ED5
"And now for something completely different."

Re: transpose-regions

[Kim F. Storm]

Andreas Schwab <schwab@suse.de> writes:

> Chong Yidong <cyd@stupidchicken.com> writes:
>
>> The problem seems to be that a cons cell that has already been
>> garbage-collected is being passed to Fcopy_sequence during
>> copy_properties(), in intervals.c:106.  Where did this cons cell come
>> from?
>>
>>   target->plist = Fcopy_sequence (source->plist);
>>
>> Is the garbage collector somehow failing to account for cons cells
>> assigned to interval plists?
>
> Unlikely, what would be a too obvious bug to remain unnoticed until now
> (and mark_interval indeed does mark the plist).  More likely that the
> whole interval is not being marked in the first place.  The function uses
> the local variables tmp_interval[12] that are copies of the buffer
> intervals, perhaps they need to be protected from GC?

There's only a need to GC around a called function if that
function can actually do GC, i.e. if calling the function may
eventually call Feval or run byte code.  Where is that possible?

Besided, a native windows build uses conservative stack marking,
so it is not necessary to explicitly protect from GC (on that
platform).   ut was this a native or a cygwin build?

Perhaps the conservative stack marking does not work properly on 
WindowsME  (does anything work properly on ME?)

-- 
Kim F. Storm <storm@cua.dk> http://www.cua.dk

Re: transpose-regions

[martin rudalics]

> Besided, a native windows build uses conservative stack marking,
> so it is not necessary to explicitly protect from GC (on that
> platform).   ut was this a native or a cygwin build?

Native.

> Perhaps the conservative stack marking does not work properly on 
> WindowsME  (does anything work properly on ME?)

I doubt that Chong uses ME ;-)

Re: transpose-regions

[Eli Zaretskii]

> From: Chong Yidong <cyd@stupidchicken.com>
> Date: Thu, 22 Mar 2007 14:06:15 -0400
> Cc: emacs-devel <emacs-devel@gnu.org>
> 
> > #4  0x0107e521 in Flength (sequence=35193781) at fns.c:185
> > (gdb) p sequence
> > $1 = 35193768
> > (gdb) xtype
> > Lisp_Int
> > (gdb) xsymbol
> > $2 = (struct Lisp_Symbol *) 0x21903a8
> > 0
> 
> Could you double check this?
> 
> Flength was called with sequence=35193781; how did it mutate into
> 35193768?  The code in Flength doesn't change the value of sequence
> (unless it is a cons cell, in which case it wouldn't end up in the
> "else" code path.)  The only way this could happen is if something
> clobbers the stack.... maybe a compiler bug?

More likely a result of optimized code confusing GDB.

Re: transpose-regions

[Eli Zaretskii]

> From: David Kastrup <dak@gnu.org>
> Date: Thu, 22 Mar 2007 22:36:10 +0100
> Cc: Nick Roberts <nickrob@snap.net.nz>, "Kim F. Storm" <storm@cua.dk>,
> 	emacs-devel <emacs-devel@gnu.org>
> 
> > X server distributor `Microsoft Corp.', version 4.90.3000
> ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
> 
> Interesting.

What's so interesting about this?  Until very recently, Emacs insisted
on printing "X server distributor" as the header of this field in the
bug report.  (It now says "Windowing system distributor" instead.)

> > configured using `configure --with-gcc (3.4)'
>                                          ^^^^^
> Not quite new, either.

There's no newer GCC for MinGW.  GCC 4.x has grave problems on Windows
(both in Cygwin and in MinGW) that will take time to resolve.  In the
meantime, I'm happily using 3.4.2 without any problems.  So I don't
see why we need to ask people to run for their lives to upgrade to the
latest and greatest.

Re: transpose-regions

[Chong Yidong]

storm@cua.dk (Kim F. Storm) writes:

>>> The problem seems to be that a cons cell that has already been
>>> garbage-collected is being passed to Fcopy_sequence during
>>> copy_properties(), in intervals.c:106.  Where did this cons cell come
>>> from?
>>>
>>>   target->plist = Fcopy_sequence (source->plist);
>>>
>>> Is the garbage collector somehow failing to account for cons cells
>>> assigned to interval plists?
>>
>> Unlikely, what would be a too obvious bug to remain unnoticed until now
>> (and mark_interval indeed does mark the plist).  More likely that the
>> whole interval is not being marked in the first place.  The function uses
>> the local variables tmp_interval[12] that are copies of the buffer
>> intervals, perhaps they need to be protected from GC?
>
> There's only a need to GC around a called function if that
> function can actually do GC, i.e. if calling the function may
> eventually call Feval or run byte code.  Where is that possible?
>
> Besided, a native windows build uses conservative stack marking,
> so it is not necessary to explicitly protect from GC (on that
> platform).   ut was this a native or a cygwin build?
>
> Perhaps the conservative stack marking does not work properly on 
> WindowsME  (does anything work properly on ME?)

I'm running on GNU/Linux with the latest CVS.

Re: transpose-regions

[Kim F. Storm]

Chong Yidong <cyd@stupidchicken.com> writes:

> I'm running on GNU/Linux with the latest CVS.

Which uses conservative stack marking too.

So it's definitely not "just" a missing GC pro somewhere.

-- 
Kim F. Storm <storm@cua.dk> http://www.cua.dk

Re: transpose-regions

[Chong Yidong]

I've narrowed down the location where the interval plist becomes
invalid.  I patched Ftranspose_regions in editfns.c as follows:

*** emacs/src/editfns.c.~1.436.~	2007-03-17 15:00:52.000000000 -0400
--- emacs/src/editfns.c	2007-03-23 11:31:06.000000000 -0400
***************
*** 4031,4036 ****
--- 4031,4038 ----
  
     It's the caller's job to ensure that START1 <= END1 <= START2 <= END2.  */
  
+ extern Lisp_Object Vdead;
+ 
  static void
  transpose_markers (start1, end1, start2, end2,
  		   start1_byte, end1_byte, start2_byte, end2_byte)
***************
*** 4224,4232 ****
--- 4226,4245 ----
  
        tmp_interval1 = copy_intervals (cur_intv, start1, len1);
        tmp_interval2 = copy_intervals (cur_intv, start2, len2);
+ 
+       if (! NULL_INTERVAL_P (tmp_interval1)
+ 	  && CONSP (tmp_interval1->plist)
+ 	  && EQ (XCAR (tmp_interval1->plist), Vdead))
+ 	abort();
+ 
        Fset_text_properties (make_number (start1), make_number (end2),
  			    Qnil, Qnil);
  
+       if (! NULL_INTERVAL_P (tmp_interval1)
+ 	  && CONSP (tmp_interval1->plist)
+ 	  && EQ (XCAR (tmp_interval1->plist), Vdead))
+ 	abort();
+ 
        /* First region smaller than second.  */
        if (len1_byte < len2_byte)
          {

Using Martin's recipe, I obtained the following backtrace:

#0  abort () at emacs.c:431
#1  0x081af617 in Ftranspose_regions (startr1=104688, endr1=105304, 
    startr2=105304, endr2=105648, leave_markers=137955529) at editfns.c:4241
...

Line 4241 corresponds to the second abort() statement, which means the
plist in tmp_interval1 got garbage collected during the call to
Fset_text_properties.  It looks like Fset_text_properties makes
changes to intervals in the buffer; probably this invalidates the
plist in tmp_interval1 in some way.

Re: transpose-regions

[Stefan Monnier]

>> I'm running on GNU/Linux with the latest CVS.
> Which uses conservative stack marking too.
> So it's definitely not "just" a missing GC pro somewhere.

I think I see the problem: intervals are not Lisp objects and thus they are
not detected by the conservative stack scanning (and they can't be GCPRO'd
either).

I.e. make_interval does:

     ...
     newi = (struct interval_block *) lisp_malloc (sizeof *newi,
                                                   MEM_TYPE_NON_LISP);
     ...

while mark_maybe_pointer does:

      ...
      switch (m->type)
	{
	case MEM_TYPE_NON_LISP:
	  /* Nothing to do; not a pointer to Lisp memory.  */
	  break;
      ...

and m->type can probably never be MEM_TYPE_NON_LISP anyway, because
lisp_malloc does:

    ...
    if (val && type != MEM_TYPE_NON_LISP)
      mem_insert (val, (char *) val + nbytes, type);
    ...


so after the copy_intervals, if Fset_text_properties ends up calling the
garbage collector (probably via some after-change-function) you're hosed.

Personally, I think the best solution is to rewrite transpose-regions in
Lisp.  After all, it's only called from gnus/deuglify.el and from
games/hanoi.el (and interactively as well, of course).


        Stefan

Re: transpose-regions

[Chong Yidong]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

> I think I see the problem: intervals are not Lisp objects and thus they are
> not detected by the conservative stack scanning (and they can't be GCPRO'd
> either).

Aha!  Yes, this is indeed the problem.

> Personally, I think the best solution is to rewrite transpose-regions in
> Lisp.  After all, it's only called from gnus/deuglify.el and from
> games/hanoi.el (and interactively as well, of course).

This is probably the long-term solution, but for Emacs 22 I think it's
not wise to change all that code.  Instead, I suggest setting
inhibit_garbage_collection around the calls to Fset_text_properties.
I have verified that this indeed solves the original bug.

*** emacs/src/editfns.c.~1.436.~	2007-03-23 13:21:29.000000000 -0400
--- emacs/src/editfns.c	2007-03-23 13:29:29.000000000 -0400
***************
*** 4118,4123 ****
--- 4118,4124 ----
    unsigned char *start1_addr, *start2_addr, *temp;
  
    INTERVAL cur_intv, tmp_interval1, tmp_interval_mid, tmp_interval2;
+   int count;
    cur_intv = BUF_INTERVALS (current_buffer);
  
    validate_region (&startr1, &endr1);
***************
*** 4224,4231 ****
--- 4225,4234 ----
  
        tmp_interval1 = copy_intervals (cur_intv, start1, len1);
        tmp_interval2 = copy_intervals (cur_intv, start2, len2);
+       count = inhibit_garbage_collection ();
        Fset_text_properties (make_number (start1), make_number (end2),
  			    Qnil, Qnil);
+       unbind_to (count, Qnil);
  
        /* First region smaller than second.  */
        if (len1_byte < len2_byte)
***************
*** 4281,4290 ****
--- 4284,4295 ----
            record_change (start2, len2);
            tmp_interval1 = copy_intervals (cur_intv, start1, len1);
            tmp_interval2 = copy_intervals (cur_intv, start2, len2);
+ 	  count = inhibit_garbage_collection ();
            Fset_text_properties (make_number (start1), make_number (end1),
  				Qnil, Qnil);
            Fset_text_properties (make_number (start2), make_number (end2),
  				Qnil, Qnil);
+ 	  unbind_to (count, Qnil);
  
  	  SAFE_ALLOCA (temp, unsigned char *, len1_byte);
  	  start1_addr = BYTE_POS_ADDR (start1_byte);
***************
*** 4310,4317 ****
--- 4315,4324 ----
            tmp_interval1 = copy_intervals (cur_intv, start1, len1);
            tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
            tmp_interval2 = copy_intervals (cur_intv, start2, len2);
+ 	  count = inhibit_garbage_collection ();
            Fset_text_properties (make_number (start1), make_number (end2),
  				Qnil, Qnil);
+ 	  unbind_to (count, Qnil);
  
  	  /* holds region 2 */
  	  SAFE_ALLOCA (temp, unsigned char *, len2_byte);
***************
*** 4341,4349 ****
            tmp_interval1 = copy_intervals (cur_intv, start1, len1);
            tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
            tmp_interval2 = copy_intervals (cur_intv, start2, len2);
            Fset_text_properties (make_number (start1), make_number (end2),
  				Qnil, Qnil);
! 
  	  /* holds region 1 */
  	  SAFE_ALLOCA (temp, unsigned char *, len1_byte);
  	  start1_addr = BYTE_POS_ADDR (start1_byte);
--- 4348,4357 ----
            tmp_interval1 = copy_intervals (cur_intv, start1, len1);
            tmp_interval_mid = copy_intervals (cur_intv, end1, len_mid);
            tmp_interval2 = copy_intervals (cur_intv, start2, len2);
+ 	  count = inhibit_garbage_collection ();
            Fset_text_properties (make_number (start1), make_number (end2),
  				Qnil, Qnil);
! 	  unbind_to (count, Qnil);
  	  /* holds region 1 */
  	  SAFE_ALLOCA (temp, unsigned char *, len1_byte);
  	  start1_addr = BYTE_POS_ADDR (start1_byte);

Re: transpose-regions

[Richard Stallman]

      The function uses
    the local variables tmp_interval[12] that are copies of the buffer
    intervals, perhaps they need to be protected from GC?

The intervals need to be protected if Lisp code can be called.  But
this can't be done in the usual way, because intervals are not Lisp
objects and not recognizable by GC.  GC knows when it is marking an
interval because it found the pointer in a string or buffer.  GCPROing
these slots in the normal way will not work.

It seems to me that the only thing that can GC in the code
where tmp_interval is in use is Fset_text_properties.
Calling set_text_properties_1 instead would avoid running hooks.
Then no GC could occur.  Does anyone see an error in this conclusion?

Ftranslate_regions is supposed to run the usual hooks for modifying
the buffer.  I suspect it does not run them properly in all cases now.
I suggest calling these hooks explicitly at the beginning and the end.

Re: transpose-regions

[martin rudalics]

> This is probably the long-term solution, but for Emacs 22 I think it's
> not wise to change all that code.  Instead, I suggest setting
> inhibit_garbage_collection around the calls to Fset_text_properties.
> I have verified that this indeed solves the original bug.

It does solve the bug.  Thank you.

Re: transpose-regions

[Richard Stallman]

    Personally, I think the best solution is to rewrite transpose-regions in
    Lisp.

The reason it is written in C is to avoid the need to copy either
piece of text into a string temporarily.

Re: transpose-regions

[Stefan Monnier]

> It seems to me that the only thing that can GC in the code
> where tmp_interval is in use is Fset_text_properties.
> Calling set_text_properties_1 instead would avoid running hooks.
> Then no GC could occur.  Does anyone see an error in this conclusion?

No.  That seems like a better fix than disabling GC.


        Stefan

Re: transpose-regions

[Stefan Monnier]

> Personally, I think the best solution is to rewrite transpose-regions
> in Lisp.

> The reason it is written in C is to avoid the need to copy either
> piece of text into a string temporarily.

I can see that, but given the fact that it's only used interactively (where
the performance impact is likely to be unnoticeable) or in gnus/deuglify.el
and game/tetris.el, I think the that performance gains do not justify
the pain and risk of writing and optimizing it in C.


        Stefan

Re: transpose-regions

[Chong Yidong]

Richard Stallman <rms@gnu.org> writes:

> It seems to me that the only thing that can GC in the code
> where tmp_interval is in use is Fset_text_properties.
> Calling set_text_properties_1 instead would avoid running hooks.
> Then no GC could occur.
>
> Ftranslate_regions is supposed to run the usual hooks for modifying
> the buffer.  I suspect it does not run them properly in all cases now.
> I suggest calling these hooks explicitly at the beginning and the end.

OK.  I've checked in such a fix.

Re: transpose-regions

[Karl Fogel]

Stefan Monnier <monnier@iro.umontreal.ca> writes:
> Personally, I think the best solution is to rewrite transpose-regions in
> Lisp.  After all, it's only called from gnus/deuglify.el and from
> games/hanoi.el (and interactively as well, of course).

By the way, there's some third-party code that uses it, in
non-interactive loops IIRC.  (http://www.red-bean.com/ale/ is one
such, I don't know if there are others.)

Re: transpose-regions

[Richard Stallman]

Thanks.

Re: transpose-regions

[Richard Stallman]

    I can see that, but given the fact that it's only used interactively (where
    the performance impact is likely to be unnoticeable) or in gnus/deuglify.el
    and game/tetris.el, I think the that performance gains do not justify
    the pain and risk of writing and optimizing it in C.

I don't agree.