emacs.scm

A framework written in Java for implementing high-level and dynamic languages, compiling them into J

(define-alias <marker> <gnu.jemacs.buffer.Marker>)
(define-alias <process> <gnu.jemacs.buffer.ProcessMode>)
(define-alias <buffer> <gnu.jemacs.buffer.Buffer>)
(define-alias <window> <gnu.jemacs.buffer.EWindow>)
(define-alias <frame> <gnu.jemacs.buffer.EFrame>)
(define-alias <keymap> <gnu.jemacs.buffer.EKeymap>)
(define-alias <toolkit> <gnu.jemacs.buffer.EToolkit>)

(define (set-size (win :: <java.awt.Component>) (w :: <int>) (h :: <int>))
  (invoke win w h))

;;; From here on, the functions are ordered as in the Lisp Reference
;;; Manual, XEmacs version 21.x.

;;; READ AND PRINT

(define (open-output-buffer (buffer <buffer>))
  (make <gnu.jemacs.buffer.BufferWriter> buffer))

(define (open-output-marker (marker <marker>))
  (make <gnu.jemacs.buffer.BufferWriter> marker #f))

;;; MINIBUFFERS

(define (read-dialog prompt)
  (symbol->string
   (invoke (as <frame> (window-frame)) 'ask prompt)))

(define read-from-minibuffer read-dialog)

;;; KEYMAPS
(define (make-keymap #!optional name)
  (make <keymap> (as <String> name)))

(define (make-sparse-keymap #!optional name)
  (make <keymap> (as <String> name)))

(define (set-keymap-name keymap new-name) #!void)  ;; ignored FIXME

(define (keymap-name (keymap <keymap>))
  (invoke keymap 'getName))

(define (set-keymap-parent (keymap  :: <keymap>) parent)
  (invoke keymap 'setParent (or parent #!null)))

(define (set-keymap-parents (keymap  :: <keymap>) parents)
  (cond ((null? parents) (invoke keymap 'setParent #!null))
	((null? (cdr parents)) (invoke keymap 'setParent (car parents)))
	(else (error "not implemented - more than one keymap parent"))))

(define (keymap-parent (keymap :: <keymap>))
  (invoke keymap 'getParent))

(define (keymap-parents keymap)
  (list (keymap-parent keymap)))

(define (set-keymap-default-binding
	 (keymap :: <keymap>) command)
  (invoke keymap 'setDefaultBinding command))
  
(define (keymap-default-binding (keymap :: <keymap>))
  (invoke keymap 'getDefaultBinding))

(define-variable global-map
  (static-field <keymap> 'globalKeymap))

(define-variable esc-map
  (static-field <keymap> 'metaKeymap))

(define (current-global-map)
  global-map)

(define (current-local-map #!optional (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'getLocalKeymap))

(define (use-local-map keymap #!optional (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'setLocalKeymap keymap))

(define (lookup-key (keymap :: <keymap>)
		    (keys :: <gnu.lists.Sequence>)
		    #!optional (accept-defaults :: <boolean> #f))
  (let ((binding
         (invoke keymap 'lookupKey keys accept-defaults)))
    (if (eq? binding #!null) #f binding)))

(define (define-key (keymap :: <keymap>) key binding)
  (invoke keymap 'defineKey key binding))

;;; MENUS

(define current-menubar #!null)

(define (set-menubar-dirty-flag #!optional (frame :: <frame> (selected-frame)))
  (invoke frame 'setMenu current-menubar))


(define (set-menubar menubar)
  (set! current-menubar menubar)
  (set-menubar-dirty-flag))

;;; MODES

(define (redraw-modeline)  ;;XEmacs has optional "all" parameter!
  (invoke (as <buffer> (current-buffer)) 'redrawModeline))

(define (force-mode-line-update) (redraw-modeline))

;;; FILES

(define (find-file #!optional (filename (read-from-minibuffer "Find file: ")))
  (switch-to-buffer (find-file-noselect filename)))

(define (find-file-noselect
         #!optional (filename (read-from-minibuffer "Find file: ")))
  (invoke-static <buffer> 'findFile filename))

(define (find-file-other-window
	 #!optional (filename
		     (read-from-minibuffer "Find file in other window: ")))
  (switch-to-buffer-other-window (find-file-noselect filename)))

(define (find-file-other-frame
	 #!optional (filename
		     (read-from-minibuffer "Find file in other frame: ")))
  (switch-to-buffer-other-frame (find-file-noselect filename)))

(define (save-buffer #!optional (buffer :: <buffer> (current-buffer)))
  (if (buffer-file-name buffer)
      (invoke buffer 'save)
      (write-file (read-from-minibuffer "File to save in: ") buffer)))

(define (write-file #!optional (filename (read-from-minibuffer "Write-file: "))
                    (buffer (current-buffer)))
  (set-visited-file-name filename buffer)
  (save-buffer buffer))

(define (insert-file #!optional (filename (read-from-minibuffer "Insert file: "))
		     (buffer (current-buffer)))
  ((primitive-virtual-method <buffer> "insertFile"
                             <void> (<String>))
   buffer filename))

;;; BUFFERS

(define (pop-to-buffer buffer
		       #!optional (not-this-window-p :: <boolean>)
		       (on-frame :: <frame> #!null))
  (select-window (display-window buffer not-this-window-p on-frame)))

(define (display-window (buffer :: <buffer>)
			#!optional (not-this-window-p :: <boolean>)
			(on-frame :: <frame> #!null))
  (invoke buffer 'display not-this-window-p on-frame))

(define (current-buffer)
  (invoke-static <buffer> 'getCurrent))

;; Emacs allows a buffer name as well as a buffer.
(define (set-buffer buffer)
  (invoke-static <buffer> 'setCurrent buffer))

;; Emacs returns an Emacs string, not a Java string. 
(define (buffer-name #!optional (buffer (current-buffer)))
  ((primitive-virtual-method <buffer> "getName"
			       <String> ())
   buffer))


(define (get-buffer buffer-or-name)
  (invoke-static <buffer> 'coerceBuffer buffer-or-name))

(define (generate-new-buffer-name starting-name)
  ((primitive-static-method <buffer> "generateNewBufferName"
			    <String> (<String>))
   starting-name))

(define (buffer-file-name #!optional (buffer :: <buffer> (current-buffer)))
  (let ((name (invoke buffer 'getFileName)))
    (if (eq? name #!null)
        #f
        (symbol->string name))))

(define (set-visited-file-name filename #!optional (buffer (current-buffer)))
  ((primitive-virtual-method <buffer> "setFileName" <void>
                             (<String>))
   buffer filename))

(define (get-buffer-create name)
  (let ((buf
	 (invoke-static  <buffer> 'getBuffer name)))
    (if (eq? buf #!null)
	(let ((toolkit :: <toolkit> (get-toolkit)))
	  (invoke toolkit 'newBuffer name))
	buf)))

(define (generate-new-buffer name)
  (let ((toolkit :: <toolkit> (get-toolkit)))
    (invoke toolkit 'newBuffer (generate-new-buffer-name name))))

;;; WINDOWS

(define (split-window #!optional (window :: <window> (selected-window)) (size :: <int> -1) (horizontal ::  <boolean> #f))
  ((primitive-virtual-method <window> "split"
			     <window> (<int> <boolean>))
   window size horizontal))

(define (split-window-vertically #!optional (arg -1))
  ; "Split current window into two windows, one above the other."
  ; (interactive "P")
  (split-window (selected-window) arg #f))

(define (split-window-horizontally #!optional (arg -1))
  ; "Split current window into two windows, one above the other."
  ; (interactive "P")
  (split-window (selected-window) arg #t))

(define (delete-window #!optional (window :: <window> (selected-window)))
  (invoke window 'delete))

(define (delete-other-windows #!optional (window (selected-window)))
  ((primitive-virtual-method <window> "deleteOtherWindows"
                             <void> ())
   window))

(define (selected-window)
  (invoke-static <window> 'getSelected))

(define (select-window (window :: <window>))
  (invoke-static <window> 'setSelected window)
  window)

;; Emacs allows extra options.
(define (next-window (window :: <window>))
  (invoke window 'getNextWindowInFrame 1))

;; Emacs allows some special values for frame.
(define (other-window #!optional (count :: <int> 1) (frame :: <frame> (selected-frame)))
  (select-window
   (invoke (frame-selected-window frame) 'getNextWindowInFrame 1)))

(define (window-buffer #!optional (window :: <window> (selected-window)))
  (invoke window 'getBuffer))

(define (switch-to-buffer
         #!optional (buffer (read-from-minibuffer "Switch to buffer: ")))
  (let ((buf (get-buffer buffer)))
    (if (eq? buf #!null)
        (set! buf (generate-new-buffer buffer)))
    (set-buffer buf)
    (set-window-buffer (selected-window) buf)))

(define (switch-to-buffer-other-window (buffer :: <buffer>))
  (pop-to-buffer buffer #t (selected-frame)))

(define (switch-to-buffer-other-frame (buffer :: <buffer>))
  (pop-to-buffer buffer #f (make-frame buffer)))

(define (set-window-buffer (window :: <window>) (buffer :: <buffer>))
  (invoke window 'setBuffer (get-buffer buffer)))

(define (window-point (window :: <window>))
  (invoke window 'getPoint))

(define (set-window-point (window :: <window>) position)
  (invoke window 'setDot (invoke (invoke window 'getBuffer) 'positionToOffset position)))

(define (window-height #!optional (window :: <window> (selected-window)))
  (invoke window 'getHeightInLines))

(define (window-width #!optional (window :: <window> (selected-window)))
  (invoke window 'getWidthInColumns))

(define (window-pixel-height #!optional (window :: <window> (selected-window)))
  (invoke window 'getHeight))

(define (window-pixel-width #!optional (window :: <window> (selected-window)))
  (invoke window 'getWidth))

(define (window-text-area-pixel-height
	 #!optional (window :: <window> (selected-window)))
  (invoke window 'getHeight))

(define (window-text-area-pixel-width
	 #!optional (window :: <window> (selected-window)))
  (invoke window 'getWidth))

;;; FRAMES

(define (get-toolkit) :: <toolkit>
  (invoke-static <gnu.jemacs.buffer.EToolkit> 'getInstance))

(define (make-frame #!optional (buffer :: <buffer> (current-buffer)))
  (let* ((toolkit :: <toolkit> (get-toolkit))
	 (frame (invoke toolkit 'newFrame buffer)))
    (set-menubar default-menubar)
    frame))

(define (delete-frame #!optional (frame :: <frame> (selected-frame)))
  (invoke frame 'delete))

;; Emacs:  frame-live-p
(define (frame-live? (frame :: <frame>))