special forms (save-excursion)

[Kalle Olavi Niemitalo <tosi at stekt dot oulu dot fi>]

How are you going to handle special forms in guile-emacs?
They can't be wrapped as easily as normal functions.
Will their C source be rewritten for Guile?

Below is a macro implementation of save-excursion.
I have tested it with:

(define (test)
  (save-excursion
    (goto-char (point-min))
    (insert "hah")))

I also tried moving the mark-active-var binding to a separate let
between define-syntax and syntax-rules, but that didn't work out.

=================================================================

(use-syntax (ice-9 syncase))
(use-modules (emacs emacs)
	     (emacs import))

(define set-marker  (emacs-import-function 'set-marker))
(define make-marker (emacs-import-function 'make-marker))
(define mark-marker (emacs-import-function 'mark-marker))

(define-syntax save-excursion
  (syntax-rules ()
    ((save-excursion body ...)
     (let ((mark-active-var (global-variable 'mark-active))
	   (outer-buffer *unspecified*)
	   (outer-point (make-marker))
	   (outer-mark (make-marker))
	   (outer-mark-active *unspecified*)
	   (inner-buffer #f)		; used as a first-time flag
	   (inner-point (make-marker))
	   (inner-mark (make-marker))
	   (inner-mark-active *unspecified*))
       (dynamic-wind
	   (lambda ()
	     ;; save outer state
	     (set! outer-buffer (current-buffer))
	     (set-marker outer-point (point))
	     (set-marker outer-mark (mark-marker))
	     (set! outer-mark-active (global-ref mark-active-var))
	     ;; restore inner state, if any
	     (cond (inner-buffer
		    (set-buffer inner-buffer)
		    (goto-char inner-point)
		    (set-marker (mark-marker) inner-mark)
		    (global-set! mark-active-var inner-mark-active))))
	   (lambda ()
	     body ...)
	   (lambda ()
	     ;; save inner state
	     (set! inner-buffer (current-buffer))
	     (set-marker inner-point (point))
	     (set-marker inner-mark (mark-marker))
	     (set! inner-mark-active (global-ref mark-active-var))
	     ;; restore outer state
	     (set-buffer outer-buffer)
	     (goto-char outer-point)
	     (set-marker (mark-marker) outer-mark)
	     (global-set! mark-active-var outer-mark-active)))))))