;; Copyright William F. Schelter. 1994
;; Licensed by GNU public license.
;; You should copy find-doc.el, gcl.el, lisp-complete.el to the emacs/lisp directory.
;; Some commands and macros for dealing with lisp
;; M-X run : run gcl or another lisp
;; m-c-x ; evaluate defun in the other window or in the last lisp which you were using.
;; m-c-x ; with a numeric arg : compile the current defun in the other window
;; m-c-d ; disassemble in other window.
;; M-x macroexpand-next : macro expand the next sexp in other window.
;; C-h d Find documentation on symbol where the cursor is.
;; C-h / Find documentation on all strings containing a given string.
;; M-p complete the current input by looking back through the buffer to see what was last typed
;; using this prompt and this beginning. Useful in shell, in lisp, in gdb,...
(setq lisp-mode-hook 'remote-lisp)
(autoload 'visit-doc-file "find-doc" nil t)
(autoload 'find-doc "find-doc" "Display documentation about STRING" t)
(autoload 'lisp-complete "lisp-complete" nil t)
(global-set-key "p" 'lisp-complete)
(global-set-key "d" 'find-doc)
(defun remote-lisp (&rest l)
(and (boundp 'lisp-mode-map)
lisp-mode-map
(define-key lisp-mode-map "\e\C-d" 'lisp-send-disassemble)
(define-key lisp-mode-map "\e\C-x" 'lisp-send-defun-compile)
(make-local-variable 'lisp-package)
(setq lisp-package nil)
(and (boundp 'remote-lisp-hook) (funcall remote-lisp-hook))
))
(defvar search-back-for-lisp-package-p nil)
;; look at the beginning of buffer to try to find an in package statement
(defun get-buffer-package ()
"Returns what it thinks is the lisp package for the current buffer.
It caches this information in the local variable `lisp-package'. It
obtains the information from searching for the first in-package from
the beginning of the file. Since in common lisp, there is only
supposed to be one such statement, it should be able to determine
this. By setting lisp-package to t, you may disable its search. This
will also disable the automatic inclusion of an in-package statement
in the tmp-lisp-file, used for sending forms to the current
lisp-process."
(cond ((eq lisp-package t) nil)
(search-back-for-lisp-package-p
(save-excursion
(cond ((re-search-backward "^[ \t]*(in-package " nil t)
(goto-char (match-end 0))
(read (current-buffer))))))
(lisp-package lisp-package)
(t
(setq
lisp-package
(let (found success)
(save-excursion
(goto-char (point-min))
(while (not found)
(if (and (setq success (search-forward "(in-package " 1000 t))
(not (save-excursion
(beginning-of-line)
(looking-at "[ \t]*;"))))
(setq found (read (current-buffer))))
(if (>= (point) 980) (setq found t))
(or success (setq found t))
))
found)))))
(defun run (arg)
"Run an inferior Lisp process, input and output via buffer *lisp*."
(interactive "sEnter name of file to run: ")
(require 'shell)
(setq lisp-mode-hook 'remote-lisp)
(switch-to-buffer (make-shell (concat arg "-lisp") arg nil "-i"))
(make-local-variable 'shell-prompt-pattern)
(setq shell-prompt-pattern "^[^#%)>]*[#%)>]+ *")
(cond ((or (string-match "maxima" arg) (string-match "affine" arg)
(save-excursion (sleep-for 2)
(re-search-backward "maxima"
(max 1 (- (point) 300))
t)))
(require 'maxima-mode)
(inferior-maxima-mode)
(goto-char (point-max))
)
(t (inferior-lisp-mode))))
(defun lisp-send-disassemble (arg)
(interactive "P")
(if arg
( lisp-send-defun-compile "disassemble-h")
( lisp-send-defun-compile "disassemble"))
)
(defvar time-to-throw-away nil)
(defvar telnet-new-line "")
(defun lisp-send-defun-compile (arg)
"Send the current defun (or other form) to the lisp-process. If there
is a numeric arg, the form (compile function-name) is also sent. The
value of lisp-process will be the process of the other exposed window (if
there is one) or else the global value of lisp-process. If the
...received message is not received, probably either the reading of
the form caused an error. If the process does not have telnet in
its name, then we write a tmp file and load it.
If :sdebug is in *features*, then si::nload is used instead of
ordinary load, in order to record line information for debugging.
The value of `lisp-package' if non nil, will be used in putting an
in-package statement at the front of the tmp file to be loaded.
`lisp-package' is determined automatically on a per file basis,
by get-buffer-package.
"
(interactive "P")
(other-window 1)
(let* ((proc (or (get-buffer-process (current-buffer)) lisp-process))
def beg
(this-lisp-process proc)
(lisp-buffer (process-buffer this-lisp-process))
fun)
(other-window 1)
(save-excursion
(end-of-defun)
(let ((end (dot)) (buffer (current-buffer))
(proc (get-process this-lisp-process)))
(setq lisp-process proc)
(beginning-of-defun)
(save-excursion
(cond ((and arg (looking-at "(def")) (setq def t))
(t (setq arg nil)))
(cond (def (forward-char 2)(forward-sexp 1)
(setq fun (read buffer))
(setq fun (prin1-to-string fun))
(message (format
"For the lisp-process %s: %s"
(prin1-to-string this-lisp-process) fun)))))
(cond ((eql (char-after (1- end)) ?\n)
(setq end (1- end)) ))
(setq beg (dot))
(my-send-region this-lisp-process beg end)
))
(send-string this-lisp-process
(concat ";;end of form" "\n" telnet-new-line))
(cond (arg
(if (numberp arg) (setq arg "compile"))
(send-string this-lisp-process (concat "(" arg "'" fun ")"
telnet-new-line))))
(and time-to-throw-away
(string-match "telnet"(buffer-name (process-buffer proc)))
(dump-output proc time-to-throw-away))
(cond (nil (get-buffer-window lisp-buffer)
(select-window (get-buffer-window lisp-buffer))
(goto-char (point-max)))
(t nil))))
(defvar telnet-new-line "")
(defvar tmp-lisp-file (concat "/tmp/" (user-login-name) ".lsp"))
(defun my-send-region (proc beg end)
(cond ((or (string-match "telnet" (process-name proc)))
(send-region proc beg end))
(t
(let ((package (get-buffer-package)))
(save-excursion
(let ((temp-buffer-show-hook '(lambda (x) nil)))
(with-output-to-temp-buffer "*tmp-gcl*"
(if package
(prin1 (list 'in-package package)))
(princ ";!(:line ")
(prin1
(let ((na (buffer-file-name (current-buffer))))
(if na (expand-file-name na)
(buffer-name (current-buffer))))
)
(princ (- (count-lines (point-min) (+ beg 5)) 1))
(princ ")\n")
(set-buffer "*tmp-gcl*")
(write-region (point-min) (point-max) tmp-lisp-file nil nil))))
(write-region beg end tmp-lisp-file t nil)
(message "sending ..")
(send-string
proc
(concat "(lisp::let ((*load-verbose* nil)) (#+sdebug si::nload #-sdebug load \""
tmp-lisp-file
"\")#+gcl(setq si::*no-prompt* t)(values))\n ")
)
(message (format "PACKAGE: %s ..done" (or package "none")))
))))
(defun dump-output (proc seconds)
"dump output for PROCESS for SECONDS or to \";;end of form\""
(let ((prev-filter (process-filter proc)) (already-waited 0))
(unwind-protect (progn (set-process-filter proc 'dump-filter)
(while (< already-waited seconds)
(sleep-for 1)(setq already-waited
(1+ already-waited))))
(set-process-filter proc prev-filter))))
(defun dump-filter (proc string)
; (setq she (cons string she))
(let ((ind (string-match ";;end of form" string)))
(cond (ind (setq string (substring
string
(+ ind (length
";;end of form"))))
(message "... received.")
(setq already-waited 1000)
(set-process-filter proc prev-filter)
(cond (prev-filter (funcall prev-filter proc string))
(t string)))
(t ""))))
;;(process-filter (get-process "lisp"))
(defun macroexpand-next ()
"macroexpand current form"
(interactive)
(save-excursion
(let ((beg (point)))
(forward-sexp )
(message "sending macro")
(let* ((current-lisp-process
(or (get-buffer-process (current-buffer))
(prog2 (other-window 1)
(get-buffer-process (current-buffer))
(other-window 1)))))
(send-string current-lisp-process "(macroexpand '")
(send-region current-lisp-process beg (point) )
(send-string current-lisp-process ")\n")))))
(defun delete-comment-char (arg)
(while (and (> arg 0) (looking-at comment-start)) (delete-char 1)
(setq arg (1- arg))))
(defun mark-long-comment ()
(interactive)
(let ((at (point)))
(beginning-of-line)
(while(and (not (eobp))
(or (looking-at comment-start)
;(looking-at "[ ]*\n")
))
(forward-line 1))
(set-mark (point))
(goto-char at)
(while(and (not (bobp))
(or (looking-at comment-start)
;(looking-at "[ ]*\n")
))
(forward-line -1))
(or (bobp )(forward-line 1))))
(defun fill-long-comment ()
(interactive)
(mark-long-comment)
(let ((beg (min (dot) (mark)))
(end (max (dot) (mark))) (n 0)m)
(narrow-to-region beg end)
(goto-char (point-min))
(while (looking-at ";")
(forward-char 1))
(setq n (- (point) beg))
(goto-char (point-min))
(while (not (eobp))
(setq m n)
(while (> m 0)
(cond ((looking-at ";")
(delete-char 1)
(cond ((looking-at " ")(delete-char 1)(setq m 0)))
(setq m (- m 1)))
(t (setq m 0))))
(forward-line 1))
(fill-region (dot-min) (dot-max))
(goto-char (point-min))
(while (not (eobp))
(cond ((looking-at "\n")
nil)
(t(insert ";; ")))
(forward-line 1))
(goto-char (point-min))
(set-mark (point-max))
(widen)))
(defun comment-region (arg)
"Comments the region, with a numeric arg deletes up to arg comment
characters from the beginning of each line in the region. The region stays,
so a second comment-region adds another comment character"
(interactive "P")
(save-excursion
(let ((beg (dot))
(ok t)(end (mark)))
(comment-region1 beg end arg))))
(defun comment-region1 (beg end arg)
(let ((ok t))
(cond((> beg end)
(let ((oth end))
(setq end beg beg oth))))
(narrow-to-region beg end)
(goto-char beg)
(unwind-protect
(while ok
(cond (arg
(delete-comment-char arg))
(t (insert-string comment-start)))
(if (< end (dot)) (setq ok nil)
(if (search-forward "\n" end t) nil (setq ok nil))) )
(widen))))
(defun trace-expression ()
(interactive)
(save-excursion
(forward-sexp )
(let ((end (point)))
(forward-sexp -1)
(other-window 1)
(let* ((proc (get-buffer-process (current-buffer)))
(current-lisp-process (or proc lisp-process)))
(other-window 1)
(message "Tracing: %s" (buffer-substring (point) end))
(send-string current-lisp-process "(trace ")
(send-region current-lisp-process (point) end)
(send-string current-lisp-process ")\n")))))
(provide 'gcl)