Mercurial > hg > xemacs-beta

comparison lisp/ilisp/ilisp-snd.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children b82b59fe008d
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; -*- Mode: Emacs-Lisp -*-
2
3 ;;; ilisp-snd.el --
4
5 ;;; This file is part of ILISP.
6 ;;; Version: 5.7
7 ;;;
8 ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
9 ;;; 1993, 1994 Ivan Vasquez
10 ;;; 1994, 1995 Marco Antoniotti and Rick Busdiecker
11 ;;;
12 ;;; Other authors' names for which this Copyright notice also holds
13 ;;; may appear later in this file.
14 ;;;
15 ;;; Send mail to 'ilisp-request@lehman.com' to be included in the
16 ;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP
17 ;;; mailing list were bugs and improvements are discussed.
18 ;;;
19 ;;; ILISP is freely redistributable under the terms found in the file
20 ;;; COPYING.
21
22
23
24 ;;;
25 ;;; ILISP send and support.
26 ;;;
27
28
29 ;;;%% Package / Symbol support
30 ;;;
31 (defun lisp-buffer-package ()
32 "Return the package for this buffer. The package name is a string.
33 If there is none, return NIL. This caches the package unless
34 ilisp-dont-cache-package is non-nil, so calling this more than once
35 is cheap."
36 (cond ((and (not (eq buffer-package 'not-yet-computed))
37 (null lisp-dont-cache-package))
38 buffer-package)
39 (ilisp-completion-package ilisp-completion-package)
40 (lisp-dont-cache-package
41 ;; Refind the package each time.
42 (let ((package (lisp-buffer-package-internal nil)))
43 (message "")
44 (setq buffer-package 'not-yet-computed)
45 (if package
46 (setq mode-name
47 (concat
48 (or buffer-mode-name
49 (setq buffer-mode-name mode-name))
50 ":" package)))
51 package))
52 ((or lisp-buffer-package
53 (memq major-mode ilisp-modes)
54 (not (memq major-mode lisp-source-modes)))
55 nil)
56 (t
57 (make-local-variable 'buffer-package)
58 (make-local-variable 'buffer-mode-name)
59 (let ((package (lisp-buffer-package-internal t)))
60 (message "")
61 (setq buffer-package package)
62 ;; Display package in mode line
63 (if package
64 (setq mode-name
65 (concat (or buffer-mode-name
66 (setq buffer-mode-name mode-name))
67 ":" buffer-package)))
68 buffer-package))))
69
70 (defun lisp-buffer-package-internal (search-from-start)
71 "Returns the package of the buffer. If SEARCH-FROM-START is T then
72 will search from the beginning of the buffer, otherwise will search
73 backwards from current point."
74 (setq mode-line-process 'ilisp-status)
75 (let* ((lisp-buffer-package t)
76 (case-fold-search t)
77 (regexp (ilisp-value 'ilisp-package-regexp t))
78 (spec
79 (if regexp
80 (save-excursion
81 (if (or (and search-from-start
82 (goto-char (point-min))
83 (re-search-forward regexp nil t))
84 (re-search-backward regexp nil t))
85 (buffer-substring (match-beginning 0)
86 (progn
87 (goto-char (match-beginning 0))
88 (forward-sexp)
89 (point)))))))
90 (str (format (ilisp-value 'ilisp-package-command) spec))
91 (package
92 (if spec
93 (ilisp-send
94 str
95 "Finding buffer package"
96 'pkg))))
97 (if (ilisp-value 'comint-errorp t)
98 (progn
99 (lisp-display-output package)
100 (error "No package"))
101 (if (and package
102 ;; There was a bug here, used to have the second *
103 ;; outside of the parens.
104 (string-match "[ \n\t:\"]*\\([^ \n\t\"]*\\)" package))
105 (setq package
106 (substring package
107 (match-beginning 1) (match-end 1)))))
108 package))
109
110 ;;;
111 (defun package-lisp ()
112 "Show current inferior LISP package."
113 (interactive)
114 (message "Inferior LISP package is %s"
115 (ilisp-send (ilisp-value 'ilisp-package-name-command)
116 "Finding inferior LISP package" 'pkg)))
117
118 ;;;
119 (defun set-package-lisp (package)
120 "Set inferior LISP to package of buffer or a named package with prefix."
121 (interactive
122 (let ((default (lisp-buffer-package)))
123 (if (or current-prefix-arg (null default))
124 (let ((name
125 (read-string
126 (format "Package [%s]: " (lisp-buffer-package)) "")))
127 (list (if (equal name "") default name)))
128 (list default))))
129 (if package
130 (ilisp-send (format (ilisp-value 'ilisp-in-package-command) package)
131 (format "Set %s's package to %s"
132 (buffer-name (ilisp-buffer))
133 package)
134 'pkg 'dispatch)
135 (error "No package")))
136
137 ;;;
138 (defun set-buffer-package-lisp (package)
139 "Reset the current package of the current buffer. With prefix
140 specify manually."
141 (interactive (if current-prefix-arg
142 (list (read-from-minibuffer "Package: " ))
143 (list nil)))
144 (if package
145 (setq buffer-package package
146 mode-name (concat (or buffer-mode-name mode-name) ":" package))
147 (setq buffer-package 'not-yet-computed)
148 (lisp-buffer-package)))
149
150
151
152 ;;;%Interface functions
153 ;;;%%Symbols
154 (defun lisp-string-to-symbol (string)
155 "Convert STRING to a symbol, (package delimiter symbol) where the
156 package is either package:symbol or from the current buffer."
157 (let* ((start (string-match ":+" string))
158 (end (if start (match-end 0))))
159 (if start
160 (lisp-symbol
161 (if (= start 0)
162 ""
163 (substring string 0 start))
164 (substring string start end)
165 (substring string end))
166 (let ((package (lisp-buffer-package)))
167 (lisp-symbol package (if package "::") string)))))
168
169 ;;;
170 (defun lisp-symbol-to-string (symbol)
171 "Convert SYMBOL to a string."
172 (apply 'concat symbol))
173
174 ;;;
175 (defun lisp-buffer-symbol (symbol)
176 "Return SYMBOL as a string qualified for the current buffer."
177 (let ((symbol-name (lisp-symbol-name symbol))
178 (pkg (lisp-symbol-package symbol))
179 (delimiter (lisp-symbol-delimiter symbol)))
180 (cond ((string= pkg (lisp-buffer-package)) symbol-name)
181 ((string= pkg "") (concat ":" symbol-name))
182 (pkg (concat pkg delimiter symbol-name))
183 (t symbol-name))))
184
185 ;;;
186 (defun lisp-previous-symbol (&optional stay)
187 "Return the immediately preceding symbol as ((package delimiter symbol)
188 function-p start end). If STAY is T, the end of the symbol will be point."
189 (save-excursion
190 (if (or (and (memq major-mode ilisp-modes)
191 (= (point) (process-mark (get-buffer-process
192 (current-buffer)))))
193 (progn
194 (skip-chars-backward " \t\n")
195 (or (bobp) (memq (char-after (1- (point))) '(?\) ?\")))))
196 nil
197 (let* ((delimiters (ilisp-value 'ilisp-symbol-delimiters))
198 (end (progn
199 (if (not stay) (skip-chars-forward delimiters))
200 (point)))
201 (start (progn
202 (skip-chars-backward delimiters)
203 (point)))
204 (prefix (if (not (bobp)) (1- start)))
205 (function-p
206 (and prefix
207 (or (eq (char-after prefix) ?\()
208 (and (eq (char-after prefix) ?')
209 (not (bobp))
210 (eq (char-after (1- prefix)) ?#)))
211 (not (looking-at "[^: \t\n]*:*\\*[^ \t\n]")))))
212 (cons (lisp-string-to-symbol (buffer-substring start end))
213 (list function-p start end))))))
214
215
216 ;;;
217 (defun lisp-function-name ()
218 "Return the previous function symbol. This is either after a #' or
219 at the start of the current sexp. If there is no current sexp, return
220 nil."
221 (save-excursion
222 (let ((symbol (lisp-previous-symbol)))
223 (if (car (cdr symbol))
224 (car symbol)
225 (condition-case ()
226 (if (and (memq major-mode ilisp-modes)
227 (= (point)
228 (process-mark
229 (get-buffer-process (current-buffer)))))
230 nil
231 (backward-up-list 1)
232 (down-list 1)
233 (lisp-string-to-symbol
234 (buffer-substring (point)
235 (progn (forward-sexp 1) (point)))))
236 (error nil))))))
237
238
239 ;;;
240 (defun lisp-defun-name ()
241 "Return the name of the current defun."
242 (save-excursion
243 (lisp-defun-begin)
244 (lisp-string-to-symbol (lisp-def-name t))))
245
246
247 ;;;%% ILISP initializations
248 ;;;
249 (defun ilisp-initialized ()
250 "Return T if the current inferior LISP has been initialized."
251 (memq (buffer-name (ilisp-buffer)) ilisp-initialized))
252
253 ;;;
254 (defun ilisp-load-init (dialect file)
255 "Add FILE to the files to be loaded into the inferior LISP when
256 dialect is initialized. If FILE is NIL, the entry will be removed."
257 (let ((old (assoc dialect ilisp-load-inits)))
258 (if file
259 (if old
260 (rplacd old file)
261 (setq ilisp-load-inits (nconc ilisp-load-inits
262 (list (cons dialect file)))))
263 (if old (setq ilisp-load-inits (delq old ilisp-load-inits))))))
264
265 ;;;
266 (defun ilisp-binary (init var)
267 "Initialize VAR to the result of INIT if VAR is NIL."
268 (if (not (ilisp-value var t))
269 (let ((binary (ilisp-value init t)))
270 (if binary
271 (comint-send
272 (ilisp-process) binary
273 t nil 'binary nil
274 (` (lambda (error wait message output last)
275 (if (or error
276 (not (string-match "\"[^\"]*\"" output)))
277 (progn
278 (lisp-display-output output)
279 (abort-commands-lisp "No binary"))
280 (setq (, var)
281 (substring output
282 (1+ (match-beginning 0))
283 (1- (match-end 0))))))))))))
284
285 ;;;
286 (defun ilisp-done-init ()
287 "Make sure that initialization is done and if not dispatch another check."
288 (if ilisp-load-files
289 (comint-send-code (get-buffer-process (current-buffer))
290 'ilisp-done-init)
291 (if ilisp-initializing
292 (progn
293 (message "Finished initializing %s" (car ilisp-dialect))
294 (setq ilisp-initializing nil
295 ilisp-initialized
296 (cons (buffer-name (current-buffer)) ilisp-initialized))))))
297
298 ;;;
299 (defun ilisp-init-internal (&optional sync)
300 "Send all of the stuff necessary to initialize."
301 (unwind-protect
302 (progn
303 (if sync
304 (comint-sync
305 (ilisp-process)
306 "\"Start sync\"" "[ \t\n]*\"Start sync\""
307 "\"End sync\"" "\"End sync\""))
308 (ilisp-binary 'ilisp-binary-command 'ilisp-binary-extension)
309 (ilisp-binary 'ilisp-init-binary-command
310 'ilisp-init-binary-extension)
311 ;; This gets executed in the process buffer
312 (comint-send-code
313 (ilisp-process)
314 (function (lambda ()
315 (let ((files ilisp-load-inits)
316 (done nil))
317 (unwind-protect
318 (progn
319 (if (not ilisp-init-binary-extension)
320 (setq ilisp-init-binary-extension
321 ilisp-binary-extension))
322 (while files
323 (ilisp-load-or-send
324 (expand-file-name
325 (cdr (car files)) ilisp-directory))
326 (setq files (cdr files)))
327 (comint-send-code (ilisp-process)
328 'ilisp-done-init)
329 (setq done t))
330 (if (not done)
331 (progn
332 (setq ilisp-initializing nil)
333 (abort-commands-lisp))))))))
334
335 (set-ilisp-value 'ilisp-initializing t)) ; progn
336
337 (if (not (ilisp-value 'ilisp-initializing t))
338 (abort-commands-lisp))))
339
340 ;;;
341 (defun ilisp-init (&optional waitp forcep sync)
342 "Initialize the current inferior LISP if necessary by loading the
343 files in ilisp-load-inits. Optional WAITP waits for initialization to
344 finish. When called interactively, force reinitialization. With a
345 prefix, get the binary extensions again."
346 (interactive
347 (list (if current-prefix-arg
348 (progn
349 (set-ilisp-value 'ilisp-init-binary-extension nil)
350 (set-ilisp-value 'ilisp-binary-extension nil)
351 nil))
352 t))
353 (if (or forcep (not (ilisp-initialized)))
354 (progn
355 (message "Started initializing ILISP")
356 (if (not ilisp-directory)
357 (setq ilisp-directory (or (ilisp-directory "ilisp.elc" load-path)
358 (ilisp-directory "ilisp.el" load-path))))
359 (if (not (ilisp-value 'ilisp-initializing t))
360 (ilisp-init-internal sync))
361 (if waitp
362 (while (ilisp-value 'ilisp-initializing t)
363 (accept-process-output)
364 (sit-for 0))))))
365
366 ;;;
367 (defun ilisp-init-and-sync ()
368 "Synchronize with the inferior LISP and then initialize."
369 (ilisp-init nil nil t))
370
371
372
373 ;;;
374 (defun call-defun-lisp (arg)
375 "Put a call of the current defun in the inferior LISP and go there.
376 If it is a \(def* name form, look up reasonable forms of name in the
377 input history unless called with prefix ARG. If not found, use \(name
378 or *name* as the call. If is not a def* form, put the whole form in
379 the buffer."
380 (interactive "P")
381 (if (save-excursion (lisp-defun-begin) (looking-at "(def"))
382 (let* ((symbol (lisp-defun-name))
383 (name (lisp-symbol-name symbol))
384 (package (if (lisp-symbol-package symbol)
385 (concat "\\("
386 (lisp-symbol-package symbol) ":+\\)?")))
387 (variablep (string-match "^\\*" name))
388 (setfp (string-match "(setf \\([^\)]+\\)" name)))
389 (switch-to-lisp t t)
390 (cond (setfp
391 (setq name
392 (substring name (match-beginning 1) (match-end 1)))
393 (lisp-match-ring (if (not arg)
394 (concat "(setf[ \t\n]*("
395 package name "[ \t\n]"))
396 (concat "(setf (" name)))
397 (variablep (lisp-match-ring (if (not arg)
398 (concat package name))
399 name))
400 (t
401 (let ((fun (concat "(" name)))
402 (setq name (regexp-quote name))
403 (or (lisp-match-ring
404 (if (not arg) (concat "(" package name "[ \t\n\)]"))
405 fun
406 (not arg))
407 (lisp-match-ring (concat "(" package
408 "[^ \t\n]*-*" name)
409 fun))))))
410 (let ((form
411 (save-excursion
412 (buffer-substring (lisp-defun-begin)
413 (lisp-end-defun-text t)))))
414 (switch-to-lisp t t)
415 (comint-kill-input)
416 (insert form))))
417
418
419
420 ;;;
421 (defun ilisp-send (string &optional message status and-go handler)
422 "Send STRING to the ILISP buffer, print MESSAGE set STATUS and
423 return the result if AND-GO is NIL, otherwise switch to ilisp if
424 and-go is T and show message and results. If AND-GO is 'dispatch,
425 then the command will be executed without waiting for results. If
426 AND-GO is 'call, then a call will be generated. If this is the first
427 time an ilisp command has been executed, the lisp will also be
428 initialized from the files in ilisp-load-inits. If there is an error,
429 comint-errorp will be T and it will be handled by HANDLER."
430 (ilisp-init t)
431 (let ((process (ilisp-process))
432 (dispatch (eq and-go 'dispatch)))
433 (if message
434 (message "%s" (if dispatch
435 (concat "Started " message)
436 message)))
437 ;; No completion table
438 (setq ilisp-original nil)
439 (if (memq and-go '(t call))
440 (progn (comint-send process string nil nil status message handler)
441 (if (eq and-go 'call)
442 (call-defun-lisp nil)
443 (switch-to-lisp t t))
444 nil)
445 (let* ((save (ilisp-value 'ilisp-save-command t))
446 (result
447 (comint-send
448 process
449 (if save (format save string) string)
450 ;; Interrupt without waiting
451 t (if (not dispatch) 'wait) status message handler)))
452 (if save
453 (comint-send
454 process
455 (ilisp-value 'ilisp-restore-command t)
456 t nil 'restore "Restore" t t))
457 (if (not dispatch)
458 (progn
459 (while (not (cdr result))
460 (sit-for 0)
461 (accept-process-output))
462 (comint-remove-whitespace (car result))))))))
463
464
465
466 ;;;
467 (defun ilisp-load-or-send (file)
468 "Try to load FILE into the inferior LISP. If the file is not
469 accessible in the inferior LISP as determined by
470 ilisp-load-or-send-command, then visit the file and send the file over
471 the process interface."
472 (let* ((command
473 (format (ilisp-value 'ilisp-load-or-send-command)
474 (lisp-file-extension
475 file
476 (ilisp-value 'ilisp-init-binary-extension t))
477 file)))
478 (set-ilisp-value 'ilisp-load-files
479 (nconc (ilisp-value 'ilisp-load-files t) (list file)))
480 (comint-send
481 (ilisp-process) command t nil 'load
482 (format "Loading %s" file)
483 (function (lambda (error wait message output last)
484 (let* ((file (lisp-last ilisp-load-files))
485 (process (get-buffer-process (current-buffer)))
486 (case-fold-search t))
487 (if (and output
488 (string-match "nil" (car (lisp-last-line output))))
489 (let* ((old-buffer (get-file-buffer file))
490 (buffer (find-file-noselect file))
491 (string (save-excursion
492 (set-buffer buffer)
493 (buffer-string))))
494 (if (not old-buffer) (kill-buffer buffer))
495 (if (string= "" string)
496 (abort-commands-lisp (format "Can't find file %s" file))
497 (comint-send
498 process
499 (format ilisp-block-command string)
500 t nil 'send (format "Sending %s" file)
501 (function (lambda (error wait message output last)
502 (if error
503 (progn
504 (comint-display-error output)
505 (abort-commands-lisp
506 (format "Error sending %s"
507 (lisp-last ilisp-load-files))))
508 (setq ilisp-load-files
509 (delq (lisp-last ilisp-load-files)
510 ilisp-load-files))))))))
511 (if error (ilisp-handler error wait message output last))
512 (setq ilisp-load-files (delq file ilisp-load-files)))))))))