emacs.scm

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

  (invoke frame 'isLive))

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

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

(define (selected-frame)
  (invoke-static <frame> 'getSelectedFrame))

;;; POSITIONS

(define (point #!optional (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'getPoint))

(define (point-min #!optional (buffer :: <buffer> (current-buffer)))
  (+ (invoke buffer 'minDot) 1))

(define (point-max #!optional (buffer :: <buffer> (current-buffer)))
  (+ (invoke buffer 'maxDot) 1))

(define (buffer-end flag #!optional (buffer :: <buffer> (current-buffer)))
  ((if (<= flag 0) point-min point-max) buffer))

(define (buffer-size #!optional (buffer :: <buffer> (current-buffer))) :: <int>
  (- (invoke buffer 'maxDot) (invoke buffer 'minDot)))

(define (goto-char position #!optional (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'setDot (invoke buffer 'positionToOffset position))
  (invoke buffer 'getDot))

#| Scheme only
(define (forward-char #!optional
		      (count :: <int> 1) (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'forwardChar count))

(define (backward-char #!optional
		      (count :: <int> 1) (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'backwardChar count))
|#

(define (point-at-bol
         #!optional
         (n  1)
         (buffer  :: <buffer> (current-buffer)))
  <int>
  (if (eq? n '()) (set! n 1))
  (+ 1 (as <int> (invoke buffer 'forwardLine (- n 1) (invoke buffer 'getDot)))))

(define (point-at-eol #!optional (count  :: <int> 1)
                      (buffer  :: <buffer> (current-buffer)))
  <int>
  (let* ((pos-shortage
          (invoke buffer 'scan
                  #\Newline (invoke buffer 'getDot)
                  0 (- count (if (> count 0) 0 1)) #t))
         (shortage (arithmetic-shift pos-shortage -32))
         (pos (as <int> pos-shortage)))
    (if (zero? shortage) pos (+ pos 1))))

;; FIXME - ineffecient!
(define (goto-line line #!optional (buffer  :: <buffer> (current-buffer)))
  (goto-char (point-min buffer) buffer)
  (forward-line (- line 1) buffer))

(define (beginning-of-line
         #!optional
         (n  1)
         (buffer :: <buffer> (current-buffer))) <void>
  (invoke buffer 'setPoint (point-at-bol n buffer)))

(define (end-of-line #!optional
                     (n :: <int> 1)
                     (buffer :: <buffer> (current-buffer)))
  <void>
  (invoke buffer 'setPoint (point-at-eol n buffer)))

(define (forward-line #!optional
                      (count :: <int> 1)
                      (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'forwardLine count))

#|
(define (next-line #!optional (count 1) (buffer :: <buffer> (current-buffer)))
  (line-move count))

(define (previous-line #!optional (count 1) (buffer :: <buffer> (current-buffer)))
  (line-move (- count)))
|#

(define (line-move arg #!optional (buffer ::  <buffer> (current-buffer)))
  (let ((goal-column (current-column buffer)))
    (forward-line arg buffer)
    (move-to-column goal-column #f buffer)))

;;; POSITIONS/EXCURSIONS

;;; MARKERS

(define (marker? x)
  (instance? x <marker>))

(define (make-marker)
  (make <marker>))

(define (point-marker #!optional
		      (share :: <boolean> #f)
		      (buffer :: <buffer> (current-buffer)))
  <marker>
  (invoke buffer 'getPointMarker share))

(define (copy-marker position #!optional kind)
  (let ((buffer :: <buffer>
		(if (marker? position)
		    (invoke (as <marker> position) 'getBuffer)
		    (current-buffer))))
    (if (eq? buffer #!null)
	(make <marker>)
	(make <marker>
	  buffer
	  (invoke buffer 'positionToOffset position)
	  (if kind 2 1)))))

(define (marker-position (marker <marker>))
  (let ((value (invoke marker 'getPoint)))
    (if (= value 0) #f value)))

(define (marker-buffer (marker <marker>))
  (invoke marker 'getBuffer))

(define (set-marker (marker <marker>) position
                    #!optional (buffer :: <buffer> (current-buffer)))
  (invoke marker 'set buffer (invoke buffer 'positionToOffset position)))

;;; TEXT

(define (insert-char ch #!optional (count '())
		     (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'insert ch (if (eq? count '()) 1 count) #!null))

(define (insert #!rest (args :: <Object[]>))
  (let ((buffer :: <buffer> (current-buffer)))
    (invoke buffer 'insertAll args #!null)))

(define (erase-buffer #!optional buffer '())
  (let ((buf :: <buffer> (if (eq? buffer '()) (current-buffer)
                             (get-buffer buffer))))
    (invoke buf 'removeAll)))

(define (delete-region start end
		       #!optional (buffer  :: <buffer> (current-buffer)))
  (let ((start-offset :: <int>
		      (invoke buffer 'positionToOffset start))
	 (end-offset :: <int>
		     (invoke buffer 'positionToOffset end)))
  (invoke buffer 'removeRegion start-offset end-offset)))

(define (delete-char #!optional (count :: <int> 1) killp
		     (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'removeChar count))

(define (delete-backward-char #!optional (count 1) killp
			      (buffer :: <buffer> (current-buffer)))
  (delete-char (- count) killp buffer))

;;; TEXT/COLUMNS

(define (current-column #!optional (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'currentColumn))

(define (move-to-column (column :: <int>)
			#!optional (force :: <boolean>) (buffer :: <buffer> (current-buffer)))
  (invoke buffer 'moveToColumn column force))

;;; PROCESSES

(define (process? obj)
  (instance? x <process>))

(define (process-send-string (process :: <process>) string)
  (invoke process 'writeToInferior string))

(define (process-buffer (process :: <process>))
  (invoke process 'getBuffer))

(define (process-mark (process :: <process>))
  (invoke process 'getProcessMark))

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

;;; NETWORK CONNECTION

; (define (open-network-stream name buffer-or-name host service) ...)

;;; DEFAULT BINDINGS

(define (emacs-help)
  (format #t "Sorry - no help available.~%~!"))

#|
(define-key global-map #(backspace) delete-backward-char)
(define-key global-map #(down) next-line)
(define-key global-map #(up) previous-line)
(define-key global-map #(left) backward-char)
(define-key global-map #(right) forward-char)
(define-key global-map "\C-a" beginning-of-line)
(define-key global-map "\C-b" backward-char)
(define-key global-map "\C-n" next-line)
(define-key global-map "\C-p" previous-line)
(define-key global-map "\C-d" delete-char)
(define-key global-map "\C-e" end-of-line)
(define-key global-map "\C-f" forward-char)
(define-key global-map "\C-x\C-w" write-file)
(define-key global-map "\C-x\C-s" save-buffer)
(define-key global-map "\C-x0" delete-window)
(define-key global-map "\C-x1" delete-other-windows)
(define-key global-map "\C-x2" split-window-vertically)
(define-key global-map "\C-x3" split-window-horizontally)
(define-key global-map "\C-x4f" find-file-other-window)
(define-key global-map "\C-xb" switch-to-buffer)
(define-key global-map "\C-xi" insert-file)
(define-key global-map "\C-x\C-f" find-file)
(define-key global-map "\C-x50" delete-frame)
(define-key global-map "\C-x52" make-frame)
(define-key global-map "\C-x5f" find-file-other-frame)
(define-key global-map "\C-xo" other-window)
(define-key global-map '(control h) emacs-help)
|#

(define default-menubar
  (list
   (list "File"
	 (vector "Open..." find-file)
	 (vector "Open in Other Window..." find-file-other-window)
	 (vector "Open in New Frame..." find-file-other-frame)
	 #("Insert File..." insert-file )
	 ;; #("View File..." view-file )
	 "------"
	 (vector "New Frame" make-frame)
	 (vector "Delete Frame" delete-frame)
	 "------"
	 #("Save" save-buffer active: (buffer-modified-p)))
   (list "Tools"
	 (vector "ELisp interaction" elisp-interaction-window)
	 (vector "Scheme interaction" scheme-interaction-window))
   #!null
   (list "Help"
	 #( "About JEmacs..." about-jemacs ) )))

(define (emacs)
  (set-buffer (get-buffer-create "*scratch*"))
  (make-frame))

;;; TELNET

(define (telnet #!optional (host (read-from-minibuffer "Open telnet connecttion to host:"))
		(port :: <int> 23))
  (let ((buffer (get-buffer-create "*Telnet*")))
    (invoke-static <gnu.jemacs.buffer.TelnetMode> 'telnetMode buffer host port)
    (use-local-map (static-field <process> 'modeMap) buffer)
    (switch-to-buffer buffer)
    buffer))    

(define (shell #!optional (cmd "/bin/bash"))
  (let ((buffer (get-buffer-create "*Shell*")))
    (invoke-static <gnu.jemacs.buffer.InfProcessMode> 'shellMode buffer cmd)
    (use-local-map (static-field <process> 'modeMap) buffer)
    (switch-to-buffer buffer)
    buffer))    

(define (scheme-interaction-window)
  (interaction-window 'scheme "Scheme interaction"))

(define (elisp-interaction-window)
  (interaction-window 'elisp "Lisp interaction"))

(define (interaction-window (lang-name :: <java.lang.String>) buffer-name)
  (let ((buffer (get-buffer-create buffer-name)))
    (invoke-static <gnu.jemacs.buffer.ReplMode> 'make buffer lang-name)
    (use-local-map (static-field <process> 'modeMap) buffer)
    (switch-to-buffer buffer)
    buffer))

(define (decode-buffer buffer)
  (if (eq? '() buffer) (current-buffer)
      (get-buffer buffer)))

(define (call-interactively command)
  (invoke-static <gnu.jemacs.buffer.Command> 'perform command))

(define (make-local-variable symbol)
  (invoke-static <gnu.jemacs.buffer.Buffer> 'makeBufferLocal symbol #f)
  symbol)
(define (make-variable-buffer-local symbol)
  (invoke-static <gnu.jemacs.buffer.Buffer> 'makeBufferLocal symbol #t)
  symbol)