Archive, batch processing
bond at cslab.kecl.ntt.co.jp
bond at cslab.kecl.ntt.co.jp
Fri Jun 13 09:46:02 CEST 2003
G'day,
I was playing in tdl-mode, and wanted to comment something, but found
I couldn't use comment-region as the comment style was undefined. So
I defined, it, and then got a bit carried away and colored it in
(using font-lock). It probably won't work with emacs 19, but I am
hoping there isn't a huge emacs19 user base anymore.
Anyway, please have a whirl,
Francis
;;; TDL-Mode for emacs 19 / epoch 12/23/93 18:20
;;; Ulrich Schaefer DFKI/DISCO; based on slant-mode.el by Jochen Bedersdorfer
(defvar tdl-mode nil)
(defvar tdl-mode-abbrev-table nil
"Abbrev table in use in TDL-mode buffers.")
(define-abbrev-table 'tdl-mode-abbrev-table ())
;;;STUFF FOR MINOR MODE (not used)
;;;(add-hook 'fi:lisp-mode-hook
;;; (function (lambda () ...)))
;;;
;;;(or (assq 'tdl-mode minor-mode-alist)
;;; (setq minor-mode-alist
;;; (cons '(tdl-mode " tdl") minor-mode-alist)))
;;;
;;;(defun tdl-mode (&optional arg)
;;; (setq tdl-mode
;;; (if (null arg) (not tdl-mode)
;;; (> (prefix-numeric-value arg) 0))))
(defvar tdl-mode-map ()
"Keymap used in TDL mode.")
(if nil ;;tdl-mode-map
()
(setq tdl-mode-map (make-sparse-keymap))
(define-key tdl-mode-map "[" 'tdl-bracket-begin)
(define-key tdl-mode-map "]" 'tdl-bracket-end)
(define-key tdl-mode-map "\e\C-x" 'eval-tdl-expression)
(define-key tdl-mode-map "\C-c\C-r" 'eval-tdl-region)
(define-key tdl-mode-map "\C-cr" 'eval-tdl-region-and-go)
(define-key tdl-mode-map "\C-c\C-s" 'eval-current-tdl-expression)
(define-key tdl-mode-map "\C-c\C-e" 'goto-end-of-tdl-expression)
(define-key tdl-mode-map "\C-c\C-a" 'goto-begin-of-tdl-expression)
(define-key tdl-mode-map "\C-c\C-b" 'eval-tdl-file)
(define-key tdl-mode-map "\177" 'backward-delete-char-untabify)
(define-key tdl-mode-map "\e\034" 'tdl-indent-region)
(define-key tdl-mode-map "\t" 'tdl-indent-command))
(defvar tdl-mode-syntax-table nil
"Syntax table in use in TDL-mode buffers.")
(if tdl-mode-syntax-table
()
(setq tdl-mode-syntax-table (make-syntax-table))
(modify-syntax-entry ?\\ "\\" tdl-mode-syntax-table)
(modify-syntax-entry ?/ "_" tdl-mode-syntax-table)
(modify-syntax-entry ?# "'" tdl-mode-syntax-table)
(modify-syntax-entry ?~ "'" tdl-mode-syntax-table)
(modify-syntax-entry ?@ "_" tdl-mode-syntax-table)
(modify-syntax-entry ?_ "_" tdl-mode-syntax-table)
(modify-syntax-entry ?+ "_" tdl-mode-syntax-table)
(modify-syntax-entry ?- "_" tdl-mode-syntax-table)
(modify-syntax-entry ?? "_" tdl-mode-syntax-table)
(modify-syntax-entry ?% "'" tdl-mode-syntax-table)
(modify-syntax-entry ?= "." tdl-mode-syntax-table)
(modify-syntax-entry ?\( "()" tdl-mode-syntax-table)
(modify-syntax-entry ?\{ "(}" tdl-mode-syntax-table)
(modify-syntax-entry ?\[ "(]" tdl-mode-syntax-table)
(modify-syntax-entry ?< "(>" tdl-mode-syntax-table)
(modify-syntax-entry ?> ")<" tdl-mode-syntax-table)
(modify-syntax-entry ?& "." tdl-mode-syntax-table)
(modify-syntax-entry ?| "." tdl-mode-syntax-table)
(modify-syntax-entry ?, "." tdl-mode-syntax-table)
(modify-syntax-entry ?. "." tdl-mode-syntax-table)
(modify-syntax-entry ?\' "'" tdl-mode-syntax-table)
(modify-syntax-entry ?\n "> " tdl-mode-syntax-table)
(modify-syntax-entry ?\f "> " tdl-mode-syntax-table)
(modify-syntax-entry ?\; "< " tdl-mode-syntax-table)
)
(defconst tdl-eval-expression-string "(tdl::eval-tdl-string \"%s\")"
"* Formatstring, containing tdl-function for evaluating tdl expression *")
(defconst tdl-eval-file-string "(tdl::include \"%s\")"
"* Formatstring, containing tdl-function for evaluating tdl file *")
(defun tdl-mode ()
"Major mode for editing TDL files.
\\{tdl-mode-map}
TDL mode supports:
- matching parentheses (,),[,],{,},<,>
- indentation (TAB key)
- connection to TDL/Common Lisp
Known bugs: TDL mode may be confused by strange comment lines and strings.
Turning on TDL mode calls the value of the variable tdl-mode-hook
with no args, if that value is non-nil."
(interactive)
(kill-all-local-variables)
(use-local-map tdl-mode-map)
(setq major-mode 'tdl-mode)
(setq mode-name "tdl")
(setq local-abbrev-table tdl-mode-abbrev-table)
(set-syntax-table tdl-mode-syntax-table)
(make-local-variable 'comment-start)
(setq comment-start ";")
(make-local-variable 'comment-style)
(setq comment-style "plain")
(make-local-variable 'font-lock-defaults)
(setq font-lock-defaults
'((tdl-font-lock-keywords tdl-font-lock-keywords-1)
nil ;;font-lock-keywords-only
nil ;;font-lock-case-fold-search.
((?\_ . "w") (?. . "w"))
nil))
(make-local-variable 'basic-indent)
(setq basic-indent 0)
(make-local-variable 'bracks-left)
(setq bracks-left 0)
(run-hooks 'tdl-mode-hook))
(defun tdl-compute-ubound ()
(beginning-of-line)
(if (re-search-backward "[^\\.]\\.[ \t]*\\(;.*\\)*\n" nil t)
(point)
(point-min)))
(defun tdl-indent-command ()
"Indent current line as TDL code"
(interactive)
(let ((indent-point (point))
(column (current-column))
(indent-me 0)
(ubound (tdl-compute-ubound))
(brack 1))
(setq basic-indent 0) ;; (calculate-tdl-indent)
(goto-char indent-point)
(beginning-of-line)
(skip-chars-forward " \t")
(if (eq (following-char) ?\;)
(goto-char indent-point)
(progn
(beginning-of-line)
(catch 'out
(while (and (not (bobp))
(not (= brack 0))
(re-search-backward "[][<>(){}=]" ubound t))
(if (and (eq (preceding-char) ?:)
(or (eq (following-char) ?=)
(eq (following-char) ?<)))
(throw 'out (setq brack 1))
(if (memq (following-char) '(?\( ?{ ?< ?\[ )) ;; Closing backwards
(setq brack (1- brack))
(if (memq (following-char) '(?\) ?} ?> ?\] )) ;; Opening backwards
(setq brack (1+ brack)))))))
(setq indent-me
(if (and (= brack 1)
(eq (preceding-char) ?:)
(or (eq (following-char) ?=)
(eq (following-char) ?<))
(not (tdl-one-line-expr-p indent-point)))
;;;(if (tdl-empty-definition-line-p indent-point)
;;; (progn (beginning-of-line)
;;; (skip-chars-forward " \t")
;;; (forward-char tdl-indent-level)
;;; (current-column)))
(progn (forward-char 1)
(skip-chars-forward " \t")
(current-column))
(if (or (bobp) (not (= brack 0)))
0
(progn (forward-char 1)
(when (and (eq (preceding-char) ?\[)
(not (tdl-comma-at-end-p indent-point)))
(progn (skip-chars-forward " \t")
(re-search-forward "[ \t]" nil t)))
(skip-chars-forward " \t")
(current-column))))) ;; + tdl-brace-offset
(goto-char indent-point)
(beginning-of-line)
(setq brack (point))
(skip-chars-forward " \t")
(delete-region brack (point))
(indent-to indent-me) ;; basic-indent
(if (> column indent-me) (goto-char indent-point))))))
(defun tdl-indent-region (begin end &optional printflag)
"indent a region of tdl expressions"
(interactive "r\nP")
(goto-char end)
(setq end (point-marker))
(goto-char begin)
(while (< (point) end)
(tdl-indent-command)
(forward-line 1)
(beginning-of-line))
(end-of-line))
(defun tdl-comma-at-end-p (indent-point)
(let* ((pos (point))
(eol (progn (goto-char indent-point)
(beginning-of-line)
(backward-char 1)
(point))))
(beginning-of-line)
(prog1
(re-search-forward ",[ \t]*\\(;.*\\)*" eol t)
(goto-char pos))))
(defun tdl-one-line-expr-p (indent-point)
(let* ((pos (point))
(eol (progn (goto-char indent-point)
(beginning-of-line)
(backward-char 1)
(point))))
(beginning-of-line)
(prog1
(re-search-forward "[^\\.]\\.[ \t]*\\(;.*\\)*" eol t)
(goto-char pos))))
;;;(defun tdl-empty-definition-line-p (indent-point)
;;; (let* ((pos (point))
;;; (eol (progn (goto-char indent-point)
;;; (beginning-of-line)
;;; (backward-char 1)
;;; (point))))
;;; (goto-char pos)
;;; (forward-char 1)
;;; (skip-chars-forward " \t" eol)
;;; (prog1
;;; (or (= (point) eol)
;;; (re-search-forward ";.*" eol t))
;;; (goto-char pos))))
;;;(defun calculate-tdl-indent ()
;;; "Determines whether there is a basic indent or not"
;;; (let* ((beg (progn (beginning-of-line) (point)))
;;; (end (progn (end-of-line) (point)))
;;; (s-string (buffer-substring beg end)))
;;; (if (and (or (string-match ".*:=.*" s-string)
;;; (string-match ".*:<.*" s-string))
;;; (not (or (string-match ".*:=.*\\.[ \t]*;*.*" s-string)
;;; (string-match ".*:<.*\\.[ \t]*;*.*" s-string))))
;;; (progn
;;; (beginning-of-line)
;;; (search-forward ":" end t)
;;; (forward-char 2)
;;; (skip-chars-forward " \t")
;;; (current-column))
;;; 0)))
(defun tdl-bracket-begin (arg)
"Begin a bracket (not used yet)"
(interactive "P")
(setq bracks-left (1+ bracks-left))
(self-insert-command (prefix-numeric-value arg)))
(defun tdl-bracket-end (arg)
"End a bracket (not used yet)"
(interactive "P")
(setq bracks-left (1- bracks-left))
(self-insert-command (prefix-numeric-value arg)))
(defun eval-tdl-file (arg)
"Saves current buffer and tries to eval it with tdl-parser"
(interactive "P")
(if (and (buffer-modified-p)
(y-or-n-p "Buffer modified! Saving before evaluating ? "))
(save-buffer))
(let ((name (buffer-file-name)))
(if (not (save-excursion (get-buffer "*TDL-Listener*")))
(fi:open-lisp-listener 0 "Tdl-Listener"))
(save-excursion
(save-window-excursion
(set-buffer "*TDL-Listener*")
(insert ?\n)
(insert (format tdl-eval-file-string name))
(message "TDL parsing ...")
(fi:lisp-eval-last-sexp)
(message "TDL parsing ...done.")))
(pop-to-buffer (current-buffer))))
(defun eval-tdl-expression (arg)
"Sends expression after or expression with point in it to lisp process"
(interactive "P")
(let ((beg 0)
(end 0)
(pos (point)))
(setq beg (calc-begin-of-tdl-expression))
(goto-char pos)
(setq end (calc-end-of-tdl-expression))
(tdl-send-region beg (min (1+ end) (point-max)))
(goto-char pos)))
(defun tdl-send-region (begin end)
"Sends buffer substring from begin to end to tdl lisp process"
(let ((expr (buffer-substring begin end)))
(save-window-excursion
(if (save-excursion (get-buffer "*TDL-Listener*"))
(send-tdl-expr-to-lisp expr)
(progn (fi:open-lisp-listener 0 "TDL-Listener")
(send-tdl-expr-to-lisp expr))))
(pop-to-buffer (current-buffer))))
(defun eval-current-tdl-expression (arg)
"Sends expression before current position to lisp process"
(interactive "P")
(eval-tdl-expression arg))
(defun calc-begin-of-tdl-expression ()
"calculates begin of a tdl expression"
(let ((pos (if (re-search-backward "[^\\.]\\.[ \t]*\\(;.*\\)*\n" nil t)
(point)
(point-min))))
(goto-char pos)
(if pos
(progn (end-of-line)
(skip-chars-forward " \t\n")
(while (eq (following-char) ?\; )
(forward-line 1)
(beginning-of-line)
(skip-chars-forward " \t\n"))
(point))
(point-min))))
(defun calc-end-of-tdl-expression ()
"calculates end of a tdl expression"
(if (eq (preceding-char) ?.)
(point)
(let ((pos (if (re-search-forward "[^\\.]\\.[ \t]*\\(;.*\\)*\n" nil t)
(point)
(point-max))))
(goto-char pos)
(if pos
(progn (search-backward "." (point-min) t)
(forward-char 1)
(point))
(point-max)))))
(defun goto-begin-of-tdl-expression (arg)
"go to begin of a tdl expression"
(interactive "P")
(goto-char (calc-begin-of-tdl-expression)))
(defun goto-end-of-tdl-expression (arg)
"go to end of a tdl expression"
(interactive "P")
(goto-char (calc-end-of-tdl-expression)))
(defun eval-tdl-region (begin end &optional printflag)
"eval a region of tdl expressions"
(interactive "r\nP")
(tdl-send-region begin end))
(defun eval-tdl-region-and-go (begin end &optional printflag)
"eval a region of tdl expressions and go to inferior lisp"
(interactive "r")
(tdl-send-region begin end)
;;if (fboundp 'find-buffer-other-screen)
;; (find-buffer-other-screen "*common-lisp*")
(switch-to-buffer "*common-lisp*"))
(defun send-tdl-expr-to-lisp (expr)
(save-excursion
(set-buffer "*TDL-Listener*")
;;;(insert ?\n)
(insert (format tdl-eval-expression-string
(tdl-convert-delimiter expr)))
(fi:lisp-eval-last-sexp)))
(defun tdl-convert-delimiter (string)
"converts '' to \\''"
(let* ((len (1- (length string)))
(i 0)
(char (aref string i))
(newstring (make-string 0 ?\n)))
(while (< i len)
(if (char-equal char ?\")
(setq newstring (concat newstring "\\" (char-to-string char)))
(setq newstring (concat newstring (char-to-string char))))
(setq i (1+ i))
(setq char (aref string i)))
newstring))
;;;
;;; Font Lock Stuff (FCB 2003-06-13) Probably only works for emacs 20+
;;;
;;;(setq tdl-font-lock-defaults
;;; '((tdl-font-lock-keywords
;;; tdl-font-lock-keywords-1)
;;; nil ;;font-lock-keywords-only
;;; nil ;;font-lock-case-fold-search.
;;; ((?\_ . "w") (?. . "w"))
;;; nil))
;;;;; goto-begin-of-tdl-expression))
(setq tdl-font-lock-keywords
'(("^\\([-a-zA-Z0-9_]+\\)[ \t]*:[=<]" ;;
(1 font-lock-function-name-face nil t)) ;; type being defined
("[=<][ \t]*\\([-a-zA-Z0-9_]+\\)" ;; type inherited from
(1 font-lock-type-face nil t))
("&[ \t]*\\([-a-zA-Z0-9_]+\\)[ \t]*&" ;; type inherited from (multiple)
(1 font-lock-type-face nil t))
; (":=" . font-lock-keyword-face)
))
(setq tdl-font-lock-keywords-1 ;;; could use this to set levels of gaudiness
'tdl-font-lock-keywords)
More information about the lkb
mailing list