source: trunk/j/src/org/armedbear/lisp/j.lisp @ 9266

Last change on this file since 9266 was 9265, checked in by piso, 16 years ago

Work in progress.

File size: 7.1 KB
Line 
1;;; j.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: j.lisp,v 1.44 2005-05-27 11:32:12 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package #:j)
21
22(export '(add-hook
23          after-save-hook
24          backward-char
25          backward-sexp
26          backward-up-list
27          beginning-of-line
28          buffer-activated-hook
29          buffer-live-p
30          buffer-name
31          buffer-pathname
32          buffer-stream-buffer
33          buffer-string
34          buffer-substring
35          char-after
36          char-before
37          copy-mark
38          current-buffer
39          current-editor
40          current-line
41          current-mark
42          current-point
43          defcommand
44          defun-at-point
45          delete-region
46          editor-buffer
47          emacs-mode
48          end-of-line
49          execute-command
50          find-file-buffer
51          forward-char
52          forward-sexp
53          get-buffer
54          get-last-event-internal-time
55          global-map-key
56          global-unmap-key
57          goto-char
58          insert
59          invoke-hook
60          invoke-later
61          key-pressed-hook
62          kill-theme
63          line-chars
64          line-flags
65          line-next
66          line-number
67          line-previous
68          lisp-shell-startup-hook
69          location-bar-cancel-input
70          log-debug
71          looking-at
72          make-buffer-stream
73          make-mark
74          map-key-for-mode
75          mark-charpos
76          mark-line
77          mark=
78          move-to-position
79          open-file-hook
80          other-editor
81          point-max
82          point-min
83          pop-to-buffer
84          re-search-backward
85          re-search-forward
86          reset-display
87          restore-focus
88          save-excursion
89          search-backward
90          search-forward
91          set-mark
92          status
93          switch-to-buffer
94          undo
95          unmap-key-for-mode
96          update-display
97          update-location-bar
98          variable-value
99          with-editor
100          with-other-editor
101          with-single-undo))
102
103(autoload 'emacs-mode "emacs")
104
105(defun reset-display ()
106  (jstatic "resetDisplay" "org.armedbear.j.Editor"))
107
108(defun log-debug (control-string &rest args)
109  (%log-debug (apply 'format nil control-string args)))
110
111(defun update-display (&optional ed)
112  (let ((method (jmethod "org.armedbear.j.Editor" "updateDisplay"))
113        (ed (or ed (current-editor))))
114    (jcall method ed)))
115
116(defun update-location-bar (&optional ed)
117  (let ((method (jmethod "org.armedbear.j.Editor" "updateLocation"))
118        (ed (or ed (current-editor))))
119    (jcall method ed)))
120
121(defun location-bar-cancel-input ()
122  (jstatic "cancelInput" "org.armedbear.j.LocationBar"))
123
124;; Internal.
125(defun %execute-command (command &optional ed)
126  (let ((method (jmethod "org.armedbear.j.Editor"
127                         "executeCommand" "java.lang.String"))
128        (ed (or ed (current-editor))))
129    (jcall method ed command)
130    (update-display ed)))
131
132(defmacro defcommand (name &optional (command nil))
133  (unless command
134    (setf command (remove #\- (string `,name))))
135  `(setf (symbol-function ',name)
136         (lambda (&optional arg)
137           (%execute-command (if arg
138                                 (concatenate 'string ,command " " arg)
139                                 ,command)))))
140
141(defcommand execute-command)
142
143;;; HOOKS
144(defun add-hook (hook function)
145  (when (symbolp hook)
146    (unless (boundp hook) (set hook nil))
147    (let ((hook-functions (symbol-value hook)))
148      (unless (memq function hook-functions)
149        (push function hook-functions)
150        (set hook hook-functions)))))
151
152(defun invoke-hook (hook &rest args)
153  (when (and (symbolp hook) (boundp hook))
154    (let ((hooks (symbol-value hook)))
155      (when hooks
156        (dolist (function hooks)
157          (apply function args))
158        t))))
159
160(defvar open-file-hook nil)
161
162(defvar buffer-activated-hook nil)
163
164(defvar after-save-hook nil)
165
166(defvar key-pressed-hook nil)
167
168(defvar lisp-shell-startup-hook nil)
169
170(defun variable-value (name &optional (kind :current) where)
171  (%variable-value name kind where))
172
173(defun set-variable-value (name kind &rest rest)
174  (let (where new-value)
175    (case (length rest)
176      (1
177       (setq where nil
178             new-value (car rest)))
179      (2
180       (setq where (car rest)
181             new-value (cadr rest)))
182      (t
183       (error 'program-error
184              :format-control "Wrong number of arguments.")))
185    (%set-variable-value name kind where new-value)))
186
187(defsetf variable-value set-variable-value)
188
189(defsetf current-editor %set-current-editor)
190
191(defsetf buffer-mark %set-buffer-mark)
192
193(defsetf editor-mark %set-editor-mark)
194
195(defsetf line-flags %set-line-flags)
196
197(defmacro with-editor (editor &rest forms)
198  (let ((old-editor (gensym)))
199  `(let ((,old-editor (current-editor)))
200     (unwind-protect
201      (progn
202        (setf (current-editor) ,editor)
203        ,@forms)
204      (update-display ,editor)
205      (setf (current-editor) ,old-editor)))))
206
207(defmacro with-other-editor (&rest forms)
208  (let ((old-editor (gensym))
209        (other-editor (gensym)))
210    `(let ((,old-editor (current-editor))
211           (,other-editor (other-editor)))
212       (unless ,other-editor
213         (error "there is no other editor"))
214       (unwind-protect
215        (progn
216          (setf (current-editor) ,other-editor)
217          ,@forms)
218        (update-display ,other-editor)
219        (setf (current-editor) ,old-editor)))))
220
221(defmacro with-single-undo (&rest forms)
222  (let ((info (gensym)))
223    `(let ((,info (begin-compound-edit)))
224       (unwind-protect
225        (progn ,@forms)
226        (end-compound-edit ,info)))))
227
228(defmacro save-excursion (&rest forms)
229  (let ((old-point (gensym)))
230    `(let ((,old-point (current-point)))
231       (unwind-protect
232        (progn ,@forms)
233        (goto-char ,old-point)))))
234
235(defun search-forward (pattern &key buffer start ignore-case whole-words-only)
236  (%search pattern :forward nil buffer start ignore-case whole-words-only))
237
238(defun search-backward (pattern &key buffer start ignore-case whole-words-only)
239  (%search pattern :backward nil buffer start ignore-case whole-words-only))
240
241(defun re-search-forward (pattern &key buffer start ignore-case whole-words-only)
242  (%search pattern :forward t buffer start ignore-case whole-words-only))
243
244(defun re-search-backward (pattern &key buffer start ignore-case whole-words-only)
245  (%search pattern :backward t buffer start ignore-case whole-words-only))
246
247(in-package "COMMON-LISP-USER")
248
249(use-package '#:j)
250
251(provide '#:j)
Note: See TracBrowser for help on using the repository browser.