archive/elisp/gcl.el

   1 ;; Copyright  William F. Schelter.   1994
   2 ;; Licensed by GNU public license.
   3
   4 ;; You should copy isp-complete.el to the emacs/lisp directory.
   5
   6 ;; Some commands and macros for dealing with lisp
   7 ;; M-X run : run gcl or another lisp
   8 ;; m-c-x ; evaluate defun in the other window or in the last lisp which you were using.
   9 ;; m-c-x ; with a numeric arg : compile the current defun in the other window
  10 ;; m-c-d ; disassemble in other window.
  11 ;; M-x macroexpand-next : macro expand the next sexp in other window.
  12 ;; C-h d Find documentation on symbol where the cursor is.
  13 ;; C-h / Find documentation on all strings containing a given string.
  14 ;; M-p complete the current input by looking back through the buffer to see what was last typed
  15 ;;        using this prompt and this beginning.   Useful in shell, in lisp, in gdb,...
  16
  17
  18 (setq lisp-mode-hook  'remote-lisp)
  19
  20 (autoload 'lisp-complete "lisp-complete" nil t)
  21 (autoload 'smart-complete "smart-complete" nil t)
  22
  23 ;(global-set-key "\ep" 'lisp-complete)
  24 (global-set-key "\ep" 'smart-complete)
  25
  26 (defun remote-lisp (&rest l)
  27   (and (boundp 'lisp-mode-map)
  28        lisp-mode-map
  29        (progn
  30   (define-key lisp-mode-map "\e\C-d" 'lisp-send-disassemble)
  31   (define-key lisp-mode-map "\e\C-x" 'lisp-send-defun-compile)
  32   (make-local-variable 'lisp-package)
  33   (setq lisp-package nil)
  34   (and (boundp 'remote-lisp-hook) (funcall remote-lisp-hook))
  35   )))
  36
  37
  38 (defvar search-back-for-lisp-package-p nil)
  39
  40 ;; look at the beginning of buffer to try to find an in package statement
  41 (defun get-buffer-package ()
  42
  43   "Returns what it thinks is the lisp package for the current buffer.
  44 It caches this information in the local variable `lisp-package'.  It
  45 obtains the information from searching for the first in-package from
  46 the beginning of the file.  Since in common lisp, there is only
  47 supposed to be one such statement, it should be able to determine
  48 this.  By setting lisp-package to t, you may disable its search.  This
  49 will also disable the automatic inclusion of an in-package statement
  50 in the tmp-lisp-file, used for sending forms to the current
  51 lisp-process."
  52
  53   (cond ((eq lisp-package t) nil)
  54         (search-back-for-lisp-package-p
  55          (save-excursion
  56            (cond ((re-search-backward "^[ \t]*(in-package "  nil t)
  57                   (goto-char (match-end 0))
  58                   (read (current-buffer))))))
  59         (lisp-package lisp-package)
  60         (t
  61          (setq
  62           lisp-package
  63           (let (found success)
  64             (save-excursion
  65               (goto-char (point-min))
  66               (while (not found)
  67                 (if (and (setq success (search-forward "(in-package " 1000 t))
  68                          (not (save-excursion
  69                                 (beginning-of-line)
  70                                 (looking-at "[ \t]*;"))))
  71                     (setq found  (read (current-buffer))))
  72                 (if (>= (point) 980) (setq found t))
  73                 (or success (setq found t))
  74                 ))
  75             found)))))
  76
  77
  78 (defun run (arg)
  79   "Run an inferior Lisp process, input and output via buffer *lisp*."
  80   (interactive "sEnter name of file to run: ")
  81   (require 'sshell)
  82   ;; in emacs 19 uncomment:
  83   ;;(require 'inf-lisp)
  84   (setq lisp-mode-hook 'remote-lisp)
  85   (switch-to-buffer  (make-sshell (concat arg "-lisp") arg nil "-i"))
  86   (make-local-variable 'shell-prompt-pattern)
  87     (setq sshell-prompt-pattern "^[^#%)>]*[#%)>]+ *")
  88     (cond ((or (string-match "maxima" arg) (string-match "affine" arg)
  89            (save-excursion     (sleep-for 2)
  90                                (re-search-backward "maxima"
  91                                                    (max 1 (- (point) 300))
  92                                                    t)))
  93            (require 'maxima-mode)
  94            (inferior-maxima-mode)
  95            (goto-char (point-max))
  96            )
  97           (t
  98            (if (boundp 'inferior-lisp-mode)
  99                (inferior-lisp-mode)
 100              (funcall lisp-mode-hook))
 101               )))
 102
 103 (defun lisp-send-disassemble (arg)
 104   (interactive "P")
 105    (if  arg
 106        ( lisp-send-defun-compile "disassemble-h")
 107             ( lisp-send-defun-compile "disassemble"))
 108      )
 109
 110 (defvar time-to-throw-away nil)
 111 (defvar telnet-new-line "")
 112
 113 (defun lisp-send-defun-compile (arg)
 114
 115   "Send the current defun (or other form) to the lisp-process.  If there
 116 is a numeric arg, the form (compile function-name) is also sent.  The
 117 value of lisp-process will be the process of the other exposed window (if
 118 there is one) or else the global value of lisp-process.  If the
 119 ...received message is not received, probably either the reading of
 120 the form caused an error.   If the process does not have telnet in
 121 its name, then we write a tmp file and load it.
 122 If :sdebug is in *features*, then si::nload is used instead of
 123 ordinary load, in order to record line information for debugging.
 124
 125 The value of `lisp-package' if non nil, will be used in putting an
 126 in-package statement at the front of the tmp file to be loaded.
 127 `lisp-package' is determined automatically on a per file basis,
 128 by get-buffer-package.
 129 "
 130
 131   (interactive "P")
 132   (other-window 1)
 133   (let* ((proc (or (get-buffer-process (current-buffer)) lisp-process))
 134          def beg
 135          (this-lisp-process proc)
 136          (lisp-buffer (process-buffer this-lisp-process))
 137          fun)
 138     (other-window 1)
 139     (save-excursion
 140       (end-of-defun)
 141       (let ((end (dot)) (buffer (current-buffer))
 142             (proc (get-process this-lisp-process)))
 143         (setq lisp-process proc)
 144         (beginning-of-defun)
 145         (save-excursion
 146           (cond ((and arg (looking-at "(def")) (setq def t))
 147                 (t (setq arg nil)))
 148           (cond (def (forward-char 2)(forward-sexp 1)
 149                      (setq fun (read buffer))
 150                      (setq fun (prin1-to-string fun))
 151                      (message (format
 152                                "For the lisp-process %s: %s"
 153                                (prin1-to-string this-lisp-process) fun)))))
 154         (cond ((equal (char-after (1- end)) ?\n)
 155                (setq end (1- end)) ))
 156         (setq beg (dot))
 157         (my-send-region this-lisp-process beg end)
 158         ))
 159
 160
 161     (send-string this-lisp-process
 162                  (concat ";;end of form" "\n" telnet-new-line))
 163     (cond (arg
 164            (if (numberp arg) (setq arg "compile"))
 165            (send-string this-lisp-process (concat "(" arg "'" fun ")"
 166                                                   telnet-new-line))))
 167     (and time-to-throw-away
 168          (string-match "telnet"(buffer-name (process-buffer proc)))
 169          (dump-output proc time-to-throw-away))
 170     (cond (nil  (get-buffer-window lisp-buffer)
 171                   (select-window (get-buffer-window lisp-buffer))
 172                   (goto-char (point-max)))
 173           (t nil))))
 174
 175 (fset 'lisp-eval-defun (symbol-function 'lisp-send-defun-compile))
 176
 177 (defvar telnet-new-line "")
 178 (defvar tmp-lisp-file (concat "/tmp/" (user-login-name) ".lsp"))
 179
 180 (defun get-buffer-clear (name)
 181   (let ((cb (current-buffer))
 182         (buf (get-buffer-create name)))
 183     (set-buffer buf)
 184     (erase-buffer)
 185     (set-buffer cb)
 186     buf))
 187
 188 (defmacro my-with-output-to-temp-buffer  (name &rest body)
 189   (append (list
 190            'let
 191            (list (list 'standard-output (list 'get-buffer-clear name))))
 192            body))
 193
 194
 195 (defun my-send-region (proc beg end)
 196   (cond ((or (string-match "telnet" (process-name proc)))
 197          (send-region proc beg end))
 198         (t
 199          (let ((package (get-buffer-package)))
 200            (save-excursion
 201                (my-with-output-to-temp-buffer  "*tmp-gcl*"
 202                  (if (and package (not (eq package t)))
 203                      (prin1 (list 'in-package  package)))
 204                  (princ ";!(:line ")
 205                  (prin1
 206                    (let ((na (buffer-file-name (current-buffer))))
 207                      (if na (expand-file-name na)
 208                        (buffer-name (current-buffer))))
 209                    )
 210                  (princ (- (count-lines (point-min) (+ beg 5)) 1))
 211                  (princ ")\n")
 212                  (set-buffer "*tmp-gcl*")
 213                  (write-region (point-min) (point-max) tmp-lisp-file nil nil)))
 214            (write-region beg end tmp-lisp-file t nil)
 215            (message "sending ..")
 216            (send-string
 217             proc
 218             (concat "(lisp::let ((*load-verbose* nil)) (#+sdebug si::nload #-sdebug load \""
 219                     tmp-lisp-file
 220                     "\")#+gcl(setq si::*no-prompt* t)(values))\n  ")
 221                         )
 222            (message (format "PACKAGE: %s ..done"
 223                             (if (or (not package) (eq package t))
 224                                 "none"
 225                               package)))
 226
 227
 228            ))))
 229
 230 (defun dump-output (proc seconds)
 231   "dump output for PROCESS for SECONDS or to \";;end of form\""
 232  (let ((prev-filter (process-filter proc)) (already-waited 0))
 233        (unwind-protect (progn (set-process-filter proc 'dump-filter)
 234                               (while (< already-waited seconds)
 235                               (sleep-for 1)(setq already-waited
 236                                                  (1+ already-waited))))
 237          (set-process-filter proc prev-filter))))
 238
 239
 240
 241 (defun dump-filter (proc string)
 242 ;  (setq she (cons string she))
 243   (let ((ind (string-match ";;end of form" string)))
 244     (cond (ind (setq string (substring
 245                              string
 246                              (+ ind (length
 247                                      ";;end of form"))))
 248
 249                (message "... received.")
 250                (setq already-waited 1000)
 251                (set-process-filter proc prev-filter)
 252                (cond (prev-filter (funcall prev-filter proc string))
 253                      (t string)))
 254           (t ""))))
 255
 256
 257 ;;(process-filter (get-process "lisp"))
 258 (defun macroexpand-next ()
 259   "macroexpand current form"
 260   (interactive)
 261   (save-excursion
 262     (let ((beg (point)))
 263       (forward-sexp )
 264       (message "sending macro")
 265
 266       (let* ((current-lisp-process
 267               (or (get-buffer-process (current-buffer))
 268                        (prog2 (other-window 1)
 269                               (get-buffer-process (current-buffer))
 270                               (other-window 1)))))
 271         (send-string current-lisp-process "(macroexpand '")
 272         (send-region current-lisp-process  beg (point) )
 273         (send-string current-lisp-process ")\n")))))
 274
 275 (defun delete-comment-char (arg)
 276   (while (and (> arg 0) (looking-at comment-start)) (delete-char 1)
 277          (setq arg (1- arg))))
 278
 279 (defun mark-long-comment ()
 280   (interactive)
 281   (let ((at (point)))
 282     (beginning-of-line)
 283     (while(and (not (eobp))
 284                (or  (looking-at comment-start)
 285                     ;(looking-at "[     ]*\n")
 286                     ))
 287       (forward-line 1))
 288     (set-mark (point))
 289     (goto-char at)
 290     (while(and (not (bobp))
 291                (or  (looking-at comment-start)
 292                     ;(looking-at "[     ]*\n")
 293                     ))
 294       (forward-line -1))
 295     (or (bobp )(forward-line 1))))
 296
 297
 298 (defun fill-long-comment ()
 299   (interactive)
 300   (mark-long-comment)
 301   (let ((beg (min (dot) (mark)))
 302         (end (max (dot) (mark))) (n 0)m)
 303     (narrow-to-region beg end)
 304     (goto-char (point-min))
 305     (while (looking-at ";")
 306       (forward-char 1))
 307     (setq n (- (point) beg))
 308     (goto-char (point-min))
 309     (while (not (eobp))
 310       (setq m n)
 311       (while (> m  0)
 312         (cond ((looking-at ";")
 313                (delete-char 1)
 314                (cond ((looking-at " ")(delete-char 1)(setq m 0)))
 315                (setq m (- m 1)))
 316               (t (setq m 0))))
 317       (forward-line 1))
 318     (fill-region (dot-min) (dot-max))
 319     (goto-char (point-min))
 320     (while (not (eobp))
 321       (cond ((looking-at "\n")
 322              nil)
 323             (t(insert ";; ")))
 324       (forward-line 1))
 325    (goto-char (point-min))
 326    (set-mark (point-max))
 327    (widen)))
 328
 329 (defun comment-region (arg)
 330   "Comments the region, with a numeric arg deletes up to arg comment
 331 characters from the beginning of each line in the region.  The region stays,
 332 so a second comment-region adds another comment character"
 333  (interactive "P")
 334  (save-excursion
 335    (let ((beg (dot))
 336          (ok t)(end (mark)))
 337           (comment-region1 beg end arg))))
 338
 339 (defun comment-region1 (beg end arg)
 340   (let ((ok t))
 341     (cond((> beg end)
 342           (let ((oth end))
 343             (setq end beg beg oth))))
 344     (narrow-to-region beg end)
 345     (goto-char beg)
 346        (unwind-protect
 347            (while ok
 348              (cond (arg
 349                     (delete-comment-char arg))
 350                    (t   (insert-string comment-start)))
 351              (if (< end (dot)) (setq ok nil)
 352                (if  (search-forward "\n" end t) nil (setq ok nil))) )
 353          (widen))))
 354
 355 (defun trace-expression ()
 356   (interactive)
 357   (save-excursion
 358      (forward-sexp )
 359     (let ((end (point)))
 360            (forward-sexp -1)
 361       (other-window 1)
 362       (let* ((proc (get-buffer-process (current-buffer)))
 363              (current-lisp-process (or  proc lisp-process)))
 364         (other-window 1)
 365         (message "Tracing: %s" (buffer-substring (point) end))
 366         (send-string current-lisp-process "(trace ")
 367         (send-region current-lisp-process (point) end)
 368         (send-string current-lisp-process ")\n")))))
 369
 370 (provide 'gcl)