source: project/chicken/branches/release/hen.el @ 13538

Last change on this file since 13538 was 6105, checked in by felix winkelmann, 13 years ago

2.711: removed old oblist access (intended for hen), removed completion from hen.el

File size: 19.8 KB
Line 
1;;; HEN.EL ---  mode for editing chicken code
2
3;; Copyright (C) 2004 Linh Dang
4
5;; Author: Linh Dang <linhd@>
6;; Maintainer: Linh Dang <linhd@>
7;; Created: 19 Apr 2004
8;; Version: 1
9;; Keywords:
10
11;; This program is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 1, or (at your option)
14;; any later version.
15
16;; This program is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19;; GNU General Public License for more details.
20
21;; A copy of the GNU General Public License can be obtained from this
22;; program's author (send electronic mail to <linhd@>) or from the
23;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
24;; USA.
25
26;; LCD Archive Entry:
27;; hen|Linh Dang|<linhd@>
28;; | mode for editing chicken code
29;; |$Date: 2004/11/22 22:36:11 $|$Revision: 1.13 $|~/packages/hen.el
30
31;;; Commentary:
32;; Hen is a mode derived from scheme-mode and is specialized for
33;; editing chicken scheme.
34;; This mode assumes:
35;;     - the user has chicken.info install
36;;     - the csi executable can be launch as "csi"
37
38;;
39;; Changes by Micky Latowicki:
40;;
41;; * Added implementation of with-temp-message, which is missing from xemacs 21.4.
42;; * Added trivial display-mouse-p, which is similarly missing.
43;; * fixed font-lock problems.
44;; * removed most calls to accept-process-output, which made
45;; hen unacceptably slow.
46;; * removed (apparently) redundant call to hen-proc-wait-prompt in
47;; hen-proc-send
48;; * updated prompt regexp pattern to include the running number.
49;; * start csi with -quiet
50;; * fixed completions, made them more like emacs lisp behaviour.
51;; Note: completions were fixed at the cost of feeding csi the commands
52;; (require 'srfi-1) and (require 'regex) before matching strings are
53;; searched for. This was done because the completions-searching code
54;; relies on these libraries. A true fix would be to statically link these
55;; libraries into csi, because the way it works now the user cannot choose
56;; to keep srfi-1 and regex out of her csi environment.
57
58;; Changes by felix:
59;;
60;; * removed hen-describe-symbol
61;; * various cleaning up
62;; * still pretty bad...
63
64;; Changes by Adhi Hargo:
65;;
66;; * automatically raise *csi* buffer on any relevant operations, and
67;;   made it a read-only buffer.
68;; * changes definition-at-point evaluation command.
69;; * s-exp evaluation no longer shown in minibuffer.
70;; * added : + Hen-mode customization group.
71;;           + Buffer evaluation command.
72;;           + csi process-terminating command, partly so I can erase
73;;             previous definitions and start anew.
74;;           + close-parens-at-point command, from SLIME.
75;;           + modification-check before compilation.
76
77;;; Code:
78
79(defconst hen-version (substring "$Revision: 1.13 $" 11 -2)
80 "$Id: hen.el,v 1.13 2004/11/22 22:36:11 flw Exp $
81
82Report bugs to: Felix Winkelmann <bunny351@gmail.com>")
83
84(require 'scheme)
85(require 'compile)
86
87;;; GROUP DECLARATION ================================================
88
89(defgroup hen nil
90  "Major mode for editing Scheme programs using Chicken."
91  :version "21.3"
92  :group 'scheme
93  :prefix "hen-")
94(defgroup hen-font-face nil
95  "Various font face configurations."
96  :group 'hen)
97
98(defun hen-version ()
99  "Outputs Hen's current version to the minibuffer."
100  (interactive)
101  (message "Hen %s" hen-version))
102
103;;; USER-CONFIGURABLE COMMANDS =======================================
104
105(defcustom hen-csc-program "csc"
106  "*Chicken compiler executable's filename."
107  :group 'hen
108  :type 'string)
109(defcustom hen-csi-program "csi"
110  "*Chicken interpreter executable's filename."
111  :group 'hen
112  :type 'string)
113(defcustom hen-build-exec-arg ""
114  "*Compiler-argument when building an executable file."
115  :group 'hen
116  :type 'string)
117(defcustom hen-build-obj-arg ""
118  "*Compiler-argument when building an object file."
119  :group 'hen
120  :type 'string)
121(defcustom hen-eval-init-arg ""
122  "*Additional interpreter argument."
123  :group 'hen
124  :type 'string)
125
126(defcustom hen-autosave-buffer-before-compile nil
127  "*Save modified file automatically before compilation.
128The default behavior is to ask the user whether to save or not."
129  :group 'hen
130  :type 'boolean)
131
132(defcustom hen-load-hook nil
133  "Hook run after entering Hen mode."
134  :group 'hen
135  :type 'hook)
136
137
138;; with-temp-message pasted from a mailing list. It's not available in my xemacs 21.4
139(unless (functionp 'with-temp-message)
140 (defmacro with-temp-message (message &rest body)
141   "Display MESSAGE temporarily while BODY is evaluated.
142The original message is restored to the echo area after BODY has finished.
143The value returned is the value of the last form in BODY."
144   (let ((current-message (make-symbol "current-message"))
145         (temp-message (make-symbol "with-temp-message")))
146     `(let ((,temp-message ,message)
147            (,current-message))
148        (unwind-protect
149            (progn
150              (when ,temp-message
151                (setq ,current-message (current-message))
152                (message "%s" ,temp-message))
153              ,@body)
154          (and ,temp-message ,current-message
155               (message "%s" ,current-message)))))))
156
157;; display-mouse-p not available in xemacs 21.4, so here's a quick fix, sort of.
158(unless (functionp 'display-mouse-p)
159 (defun display-mouse-p (&optional display) t))
160
161(defconst hen-syntax-table
162 (let ((tab (copy-syntax-table scheme-mode-syntax-table)))
163   (modify-syntax-entry ?# "_   " tab)
164   (modify-syntax-entry ?: "_   " tab)
165   (modify-syntax-entry ?\[ "(]  " tab)
166   (modify-syntax-entry ?\] ")[  " tab)
167
168   tab))
169
170(defconst hen-font-lock-keywords-1
171 (eval-when-compile
172   (list
173    ;; Declarations
174    (list (concat "\\(?:(\\|\\[\\)"
175                  "\\(" (regexp-opt
176                         '("define"
177                           "define-class"
178                           "define-external"
179                           "define-constant"
180                           "define-datatype"
181                           "define-foreign-type"
182                           "define-foreign-variable"
183                           "define-foreign-record"
184                           "define-generic"
185                           "define-inline"
186                           "define-macro"
187                           "define-method"
188                           "define-reader-ctor"
189                           "define-record"
190                           "defstruct"
191                           "define-record-printer"
192                           "define-record-type"
193                           "define-compiler-macro"
194                           "define-syntax"
195                           "define-for-syntax"
196                           "define-values") 1) "\\)"
197                           "\\s-+(?\\(\\(\\sw\\|\\s_\\)+\\)")
198
199          '(1 font-lock-keyword-face t t)
200          '(2 font-lock-function-name-face t t))))
201 "Basic font-locking for Hen mode.")
202
203(defconst hen-font-lock-keywords-2
204 (append hen-font-lock-keywords-1
205  (eval-when-compile
206    (list
207     ;;
208     ;; Control structures.
209     (cons
210      (concat
211       "\\<" (regexp-opt
212            '("begin" "begin0" "else"
213              "else"
214              "foreign-lambda*" "foreign-safe-lambda*" "foreign-primitive"
215              "foreign-declare" "foreign-parse" "foreign-parse/declare"
216              "foreign-lambda" "foreign-safe-lambda" "foreign-code"
217              "match" "match-lambda" "match-lambda*" "match-define" "match-let" "match-let*"
218
219              "case" "case-lambda" "cond" "cond-expand" "condition-case" "select"
220              "handle-exceptions"
221              "cut" "cute" "time" "regex-case"
222
223              "do" "else" "if" "lambda" "when" "while" "if*" "unless"
224
225              "let-location" "location" "rec"
226              "let" "let*" "let-syntax" "letrec" "letrec-syntax" "set!-values"
227              "and-let*" "let-optionals" "let-optionals*" "optional"
228              "fluid-let" "let-values" "let*-values" "letrec-values"
229              "parameterize"
230              "module" "import-only" "import" "import*"
231
232              "and" "or" "delay" "receive"
233
234              "assert" "ignore-errors" "ensure" "eval-when"
235
236              "loop" "sc-macro-transformer"
237
238              "declare" "include" "require-extension" "require" "require-for-syntax" "use" "quasiquote"
239
240              "syntax" "with-syntax" "syntax-case" "identifier-syntax" "syntax-rules") t)
241       "\\>") 'font-lock-keyword-face)
242     '("\\<set!" . font-lock-keyword-face)
243     ;;
244     ;;  `:' keywords as builtins.
245     '("#?\\<:\\sw+\\>" . font-lock-builtin-face)
246     '("\\<\\sw+:\\>" . font-lock-builtin-face)
247     '(",@?\\|`" . font-lock-builtin-face)
248     '("\\(##\\sw+#\\)" (1 font-lock-builtin-face t nil))
249     '("#\\\\?\\sw+"  (0 font-lock-constant-face nil t))
250;?      '("(\\(declare\\|require\\(-extension\\)?\\)" . font-lock-keyword-face)
251     )))
252 "Gaudy expressions to highlight in Hen mode.")
253
254(defconst hen-font-lock-keywords hen-font-lock-keywords-2)
255
256(mapc (lambda (cell)
257       (put (car cell) 'scheme-indent-function (cdr cell)))
258     '((begin0 . 0)
259
260       (when . 1) (while . 1) (unless . 1)
261       (and-let* . 1) (fluid-let . 1)
262
263       (call-with-input-pipe . 1)
264       (call-with-ouput-pipe . 1)
265       (call-with-input-string . 1)
266       (call-with-input-string . 1)
267
268       (call-with-values . 1)
269
270       (with-input-from-pipe . 1)
271       (with-ouput-to-pipe . 0)
272       (with-input-from-string . 1)
273       (with-output-to-string . 0)
274
275       (if* . 2)))
276
277(defun hen-identifier-at-point ()
278 "Return the identifier close to the cursor."
279 (save-excursion
280   (save-match-data
281     (let ((beg (line-beginning-position))
282           (end (line-end-position))
283           (pos (point)))
284     (cond ((progn (goto-char pos)
285                   (skip-chars-forward " \t" end)
286                   (skip-syntax-backward "w_" beg)
287                   (memq (char-syntax (following-char)) '(?w ?_)))
288            (buffer-substring-no-properties (point) (progn (forward-sexp 1) (point))))
289           ((progn (goto-char pos)
290                   (skip-chars-backward " \t" beg)
291                   (skip-syntax-forward "w_" end)
292                   (memq (char-syntax (preceding-char)) '(?w ?_)))
293            (buffer-substring-no-properties (point) (progn (forward-sexp -1) (point))))
294           (t nil))))))
295
296(defun hen-build (cmd args)
297  (when (and (buffer-modified-p)
298             (or hen-autosave-buffer-before-compile
299                 (progn (beep)
300                        (y-or-n-p "File modified. Save it? "))))
301    (save-buffer))
302 (compile-internal (mapconcat 'identity (cons cmd args) " ")
303                   "No more errors" "csc" nil
304                   `(("Error:.+in line \\([0-9]+\\):" 0 1 nil ,(buffer-file-name)))
305                   (lambda (ignored) "*csc*")))
306
307(defun hen-build-extension ()
308  (interactive)
309  (let* ((file-name (file-name-nondirectory
310                     (buffer-file-name))))
311    (hen-build hen-csc-program (list "-s" file-name hen-build-obj-arg))))
312
313(defun hen-build-program ()
314 (interactive)
315 (let* ((file-name (file-name-nondirectory
316                     (buffer-file-name))))
317    (hen-build hen-csc-program (list file-name hen-build-exec-arg))))
318
319(define-derived-mode hen-mode scheme-mode "Hen"
320 "Mode for editing chicken Scheme code.
321\\[hen-csi-eval-last-sexp] evaluates the sexp at/preceding point in csi.
322\\[hen-csi-eval-region] evaluates the region in csi.
323\\[hen-csi-eval-buffer] evaluates current buffer in csi.
324\\[hen-csi-eval-definition] evaluates the toplevel definition at point in csi.
325\\[hen-csi-send] reads a sexp from the user and evaluates it csi.
326\\[hen-csi-proc-delete] terminates csi subprocess.
327\\[hen-close-parens-at-point] closes parentheses for top-level sexp at point.
328\\[hen-build-extension] compiles the current file as a shared object
329\\[hen-build-program] compiles the current file as a program
330"
331
332 (set-syntax-table hen-syntax-table)
333 (setq local-abbrev-table scheme-mode-abbrev-table)
334
335  (define-key hen-mode-map (kbd "C-c C-e") 'hen-csi-eval-last-sexp)
336  (define-key hen-mode-map (kbd "C-c C-r") 'hen-csi-eval-region)
337  (define-key hen-mode-map (kbd "C-c C-b") 'hen-csi-eval-buffer)
338  (define-key hen-mode-map (kbd "C-c C-d") 'hen-csi-eval-definition)
339  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
340  (define-key hen-mode-map (kbd "C-c C-x") 'hen-csi-send)
341  (define-key hen-mode-map (kbd "C-c C-q") 'hen-csi-proc-delete)
342  (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-extension)
343  (define-key hen-mode-map (kbd "C-c C-c") 'hen-build-program)
344  (define-key hen-mode-map (kbd "C-c C-]") 'hen-close-parens-at-point)
345
346  (define-key hen-mode-map [menu-bar scheme run-scheme] nil)
347  (define-key hen-mode-map [menu-bar shared build-prog] '("Compile File" hen-build-program))
348  (define-key hen-mode-map [menu-bar shared send-to-csi] '("Evaluate" . hen-csi-send))
349  (define-key hen-mode-map [menu-bar scheme build-as-extension]
350    '("Compile File as Extension" . hen-build-extension))
351  (define-key hen-mode-map [menu-bar scheme eval-buffer] '("Eval Buffer" . hen-csi-eval-buffer))
352  (define-key hen-mode-map [menu-bar scheme eval-region] '("Eval Region" . hen-csi-eval-region))
353  (define-key hen-mode-map [menu-bar scheme eval-last-sexp]
354    '("Eval Last S-Expression" . hen-csi-eval-last-sexp))
355
356  (setq font-lock-defaults
357        '((hen-font-lock-keywords
358           hen-font-lock-keywords-1 hen-font-lock-keywords-2)
359          nil t
360          ((?+ . "w") (?- . "w") (?* . "w") (?/ . "w")
361           (?. . "w") (?< . "w") (?> . "w") (?= . "w")
362           (?? . "w") (?$ . "w") (?% . "w") (?_ . "w")
363           (?& . "w") (?~ . "w") (?^ . "w") (?: . "w"))
364          beginning-of-defun
365          (font-lock-mark-block-function . mark-defun)))
366  (make-local-variable 'paragraph-start)
367  (setq paragraph-start (concat page-delimiter "\\|$" ))
368
369  (make-local-variable 'paragraph-separate)
370  (setq paragraph-separate paragraph-start)
371
372  (make-local-variable 'paragraph-ignore-fill-prefix)
373  (setq paragraph-ignore-fill-prefix t)
374
375  (make-local-variable 'adaptive-fill-mode)
376  (setq adaptive-fill-mode nil)
377
378  (make-local-variable 'parse-sexp-ignore-comments)
379  (setq parse-sexp-ignore-comments t)
380
381  (make-local-variable 'outline-regexp)
382  (setq outline-regexp ";;;;* \\|(")
383
384  (make-local-variable 'comment-start)
385  (setq comment-start ";")
386
387  (make-local-variable 'comment-column)
388  (setq comment-column 40)
389
390  (make-local-variable 'comment-add)
391  (setf comment-add 1)
392  )
393
394;;stolen from cxref
395(defun hen-looking-backward-at (regexp)
396 "Return t if text before point matches regular expression REGEXP.
397This function modifies the match data that `match-beginning',
398`match-end' and `match-data' access; save and restore the match
399data if you want to preserve them."
400 (save-excursion
401   (let ((here (point)))
402     (if (re-search-backward regexp (point-min) t)
403         (if (re-search-forward regexp here t)
404             (= (point) here))))))
405
406(defun hen-proc-wait-prompt (proc prompt-re &optional timeout msg)
407  "Wait for the prompt of interactive process PROC. PROMPT-RE must be
408a regexp matching the prompt. TIMEOUT is the amount of time to wait in
409secs before giving up. MSG is the message to display while waiting."
410  (setq timeout (if (numberp timeout) (* timeout 2) 60))
411  (unless (stringp msg)
412    (setq msg (concat "wait for " hen-csi-proc-name "'s prompt")))
413  (goto-char (process-mark proc))
414  (if (hen-looking-backward-at prompt-re)
415      t
416    (while (and (> timeout 0) (not (hen-looking-backward-at prompt-re)))
417      (with-temp-message (setq msg (concat msg "."))
418        (accept-process-output proc 0 timeout))
419      (setq timeout (1- timeout))
420      (goto-char (process-mark proc)))
421    (with-temp-message (concat msg (if (> timeout 0)
422                                       " got it!" " timeout!"))
423      (sit-for 0 100))
424    (> timeout 0))
425  )
426
427(defun hen-proc-send (question proc prompt-re &optional timeout msg)
428 "Send the string QUESTION to interactive process proc. PROMPT-RE is
429the regexp matching PROC's prompt. TIMEOUT is the amount of time to
430wait in secs before giving up. MSG is the message to display while
431waiting."
432  (setq timeout (if (numberp timeout) (* timeout 2) 60))
433  (save-excursion
434    (set-buffer (process-buffer proc))
435    (widen)
436    (save-match-data
437      (goto-char (process-mark proc))
438      (if (hen-looking-backward-at prompt-re)
439          (let ((start (match-end 0)))
440            (narrow-to-region start (point-max))
441            (process-send-string proc (concat question "\n"))
442            (hen-proc-wait-prompt proc prompt-re timeout msg)
443            (narrow-to-region start (match-beginning 0))
444            (current-buffer))))))
445
446(defconst hen-csi-prompt-pattern "#;[0-9]*> ")
447(defconst hen-csi-proc-name "csi")
448(defconst hen-csi-buffer-name "*csi*")
449
450(defun hen-csi-buffer-create ()
451  "Creates a new buffer for csi, make it read-only."
452  (let ((buffer (get-buffer-create hen-csi-buffer-name)))
453    (with-current-buffer buffer
454      (make-local-variable 'buffer-read-only)
455      (setf buffer-read-only t))
456    buffer))
457
458(defun hen-csi-buffer-erase ()
459  "Erases csi buffer's content, used mainly when its process was being
460reset."
461  (let ((buffer (get-buffer hen-csi-buffer-name)))
462    (unless (null buffer) (with-current-buffer buffer
463                            (setf buffer-read-only '())
464                            (erase-buffer)
465                            (setf buffer-read-only t)))))
466
467(defun hen-csi-buffer ()
468  (let ((buffer (or (get-buffer hen-csi-buffer-name) ;check if exists
469                    (hen-csi-buffer-create)))) ;... or create one
470    (display-buffer buffer)
471    buffer))
472
473(defun hen-csi-proc ()
474  (let ((proc (get-process hen-csi-proc-name)))
475    (if (and (processp proc)
476             (eq (process-status proc) 'run))
477        proc
478      (setq proc
479            (eval `(start-process hen-csi-proc-name (hen-csi-buffer)
480                                  hen-csi-program
481                                  "-no-init" "-quiet" "-:c" "-R" "srfi-1" "-R" "regex" "-R" "utils"
482                                  ,@(split-string hen-eval-init-arg))))
483      (with-current-buffer (hen-csi-buffer)
484        (hen-proc-wait-prompt proc hen-csi-prompt-pattern)
485        proc))))
486
487(defun hen-csi-proc-delete ()
488  (interactive)
489  (let ((proc (get-process hen-csi-proc-name)))
490    (when (and (processp proc)
491               (eq (process-status proc) 'run))
492      (delete-process proc))
493    (hen-csi-buffer-erase)
494    ()))
495
496(defun hen-csi-send (sexp)
497  "Evaluate SEXP in CSI"
498  (interactive
499   (let ((sexp (read-string "Evaluate S-expression: "))
500         (send-sexp-p nil))
501     (unwind-protect
502         (progn
503           (let ((obarray (make-vector 11 0)))
504             (read sexp)
505             (setq send-sexp-p t)))
506       (unless send-sexp-p
507         (setq send-sexp-p
508               (y-or-n-p (format "`%s' is not a valid sexp! evaluate anyway? " sexp)))))
509     (list (if send-sexp-p sexp nil))))
510  (when (stringp sexp)
511    (let* ((proc (hen-csi-proc))
512           (buf (hen-proc-send (concat sexp "\n") proc hen-csi-prompt-pattern))
513           result len)
514      (unless (buffer-live-p buf)
515        (error "Internal hen-mode failure"))
516
517      (save-excursion
518        (with-current-buffer buf
519          (setq result (buffer-string))
520          (setq len (length result))
521          (if (and (> len 0)
522                   (eq (aref result (1- len)) ?\n))
523              (setq result (substring result 0 -1)))
524          result)))))
525
526(defun hen-csi-eval-buffer ()
527  "Evaluate the current buffer in CSI"
528  (interactive)
529  (hen-csi-send (buffer-string)))
530
531(defun hen-csi-eval-region (beg end)
532  "Evaluate the current region in CSI."
533  (interactive "r")
534  (hen-csi-send (buffer-substring beg end)))
535
536(defun hen-csi-eval-last-sexp ()
537  "Evaluate the s-expression at point in CSI"
538  (interactive)
539  (hen-csi-eval-region (save-excursion (backward-sexp) (point))
540                       (point)))
541
542(defun hen-csi-eval-definition ()
543  "Evaluate the enclosing top-level form in CSI."
544  (interactive)
545  (hen-csi-eval-region (save-excursion
546                         (end-of-defun) (beginning-of-defun)
547                         (point))
548                       (save-excursion
549                         (end-of-defun) (point))))
550
551;; from SLIME
552(defun hen-close-parens-at-point ()
553  "Close parenthesis at point to complete the top-level-form.  Simply
554inserts ')' characters at point until `beginning-of-defun' and
555`end-of-defun' execute without errors, or internal variable
556`close-parens-limit' is exceeded."
557  (interactive)
558  (let ((close-parens-limit 16))
559    (loop for i from 1 to close-parens-limit
560          until (save-excursion
561                  (beginning-of-defun)
562                  (ignore-errors (end-of-defun) t))
563          do (insert ")"))))
564
565(provide 'hen)
566(run-hooks 'hen-load-hook)
567;;; HEN.EL ends here
Note: See TracBrowser for help on using the repository browser.