Download
(defvar chill-mode-hook nil
"*List of hook functions run by `chill-mode'.")
(defvar ch-indent 2
"*This variable gives the indentation in CHILL-Mode")
(defvar ch-auto-indent t
"*Indent on special characters (newline, ';' and ':')
set to nil for NO autoindent")
(defvar ch-proc-end-on-else-handler "END ON ELSE\n;"
"*END ON ELSE Handler for CHILL procedure/process")
(require 'font-lock)
(require 'func-menu)
(require 'etags)
(defvar chill-keywords
'(
"addr" "all" "and" "array" "asm" "assert" "based" "begin"
"bit_string_literal" "buffer" "by" "call" "case" "cause"
"char_string_literal" "continue" "dcl" "delay" "do" "down" "dynamic"
"else" "elsif" "end" "esac" "event" "ever" "exceptions" "exit" "fi"
"for" "forbid" "general" "goto" "grant" "if" "in" "init" "inline"
"inout" "integer_literal" "loc" "long_int_literal" "long_loc"
"long_ref" "mod" "module" "name" "newmode" "non_linked" "nopack" "not"
"od" "of" "on" "or" "out" "pack" "pervasive" "pos" "powerset"
"priority" "proc" "process" "range" "read" "receive" "recursive"
"redefined" "ref" "region" "rem" "result" "return" "returns" "row"
"seize" "send" "set" "signal" "simple" "start" "static" "step" "stop"
"struct" "syn" "synmode" "then" "to" "up" "while" "with" "xor"
"false" "true" "null" "abs" "pred" "size" "subbit" "substr" "succ"
"num" "length" "sizeof" "instance" "this" "upper" "lower" "extend"
"truncate"
)
"list of all chill keywords")
(defvar chill-types
'( "byte" "ubyte" "int" "uint" "long" "ulong" "bit"
"bin" "bit"
"long_int" "amp_int"
"bool" "char" "float" "real" "long_real" "instance"
"ptr" "long_ptr"
"char" "float" "double" "void" "struct"
"num" "min" "max" "card" "writetext" "readtext" "size" "length"
"trunc" "round" "pred" "read" "readonly" "readwrite" "writeonly"
"addr"
"lower" "upper"
"true" "false"
)
"list of all predefined chill symbols")
(defvar ch-grt-file-ext ""
"Extension for USE_SEIZE_FILE.
use \".grt\" for gnu-chill")
(defvar chill-mode-syntax-table nil
"Syntax table used while in CHILL mode.")
(defvar chill-mode-abbrev-table nil
"Abbrev table used while in CHILL mode.")
(define-abbrev-table 'chill-mode-abbrev-table ())
(defvar chill-mode-map nil
"Mode map used while in CHILL mode.")
(defconst chill-mode-menu
'("Chill"
["Comment Out Region" comment-region (mark)]
("Insert"
["New Module" ch-definition t ]
["Header" ch-header t ]
["Message Loop" ch-message-loop t]
["Begin/end" ch-begin t]
["Case" ch-case t ]
["Comment" ch-add-comment t]
["Do for" ch-for t]
["Do with" ch-with t]
["Do while" ch-while t]
["If" ch-if t ]
["Procedure" ch-procedure t]
["Process" ch-process t]
["Get Record" ch-get-record t ]
["Receive Signal" ch-receive-signal t ]
["Start Timeout" ch-start-signal-timeout t ]
)
("Goto"
["proc/process/module" chill-goto-PROC t]
["dcl/syn/synmode/newmode" chill-goto-DCL t]
["Function" fume-prompt-function-goto t]
)
("Change"
("Keywords"
["downcase" chill-downcase-keywords t]
["upcase" chill-upcase-keywords t]
["capitalize" chill-capitalize-keywords t]
)
("Modes"
["downcase" chill-downcase-types t]
["upcase" chill-upcase-types t]
["capitalize" chill-capitalize-types t]
)
)
("Debug"
["Start Debugger" start-gdb-other-window t]
["Start Debugger & Run" start-gdb-other-window-and-run t]
)
("Tags"
["Insert Global Symbol" ch-insert-global-symbol t]
["Insert SEIZE statement" ch-insert-seize t]
["Find TAG" find-tag t]
["Find TAG other Window" find-tag-other-window t]
)
["------" nil t]
["Refontify" font-lock-fontify-buffer t]
)
"XEmacs menu for Chill mode.")
(defun ch-popup-menu (e)
"Pops up the Chill menu."
(interactive "@e")
(popup-menu chill-mode-menu)
(and (boundp 'zmacs-region-stays)
(setq zmacs-region-stays t)))
(if chill-mode-syntax-table
()
(setq chill-mode-syntax-table (make-syntax-table))
(modify-syntax-entry ?' ". " chill-mode-syntax-table)
(modify-syntax-entry ?\\ ". " chill-mode-syntax-table)
(modify-syntax-entry ?/ ". 14" chill-mode-syntax-table)
(modify-syntax-entry ?* ". 23" chill-mode-syntax-table)
(modify-syntax-entry ?- ". 56b" chill-mode-syntax-table)
(modify-syntax-entry ?\^m "> b" chill-mode-syntax-table)
(modify-syntax-entry ?\n "> b" chill-mode-syntax-table)
)
(if chill-mode-map
()
(setq chill-mode-map (make-sparse-keymap))
(define-key chill-mode-map "\177" 'backward-delete-char-untabify)
(define-key chill-mode-map "\15" 'newline-and-indent)
(define-key chill-mode-map ";" 'ch-electric-char)
(define-key chill-mode-map ":" 'ch-electric-char)
(define-key chill-mode-map "\C-cb" 'ch-begin)
(define-key chill-mode-map "\C-cc" 'ch-case)
(define-key chill-mode-map "\C-cd" 'ch-definition)
(define-key chill-mode-map "\C-ce" 'ch-else)
(define-key chill-mode-map "\C-cf" 'ch-for)
(define-key chill-mode-map "\C-cg" 'ch-get-record)
(define-key chill-mode-map "\C-ch" 'ch-header)
(define-key chill-mode-map "\C-ci" 'ch-if)
(define-key chill-mode-map "\C-cm" 'ch-message-loop)
(define-key chill-mode-map "\C-cl" 'ch-loop)
(define-key chill-mode-map "\C-co" 'ch-or)
(define-key chill-mode-map "\C-cp" 'ch-procedure)
(define-key chill-mode-map "\C-c\C-p" 'ch-process)
(define-key chill-mode-map "\C-c\C-w" 'ch-with)
(define-key chill-mode-map "\C-cr" 'ch-record)
(define-key chill-mode-map "\C-c\C-r" 'ch-receive-signal)
(define-key chill-mode-map "\C-cs" 'ch-insert-seize)
(define-key chill-mode-map "\C-c\C-s" 'ch-start-signal-timeout)
(define-key chill-mode-map "\C-ct" 'ch-type)
(define-key chill-mode-map "\C-cv" 'ch-var)
(define-key chill-mode-map "\C-cw" 'ch-while)
(define-key chill-mode-map "\C-cx" 'ch-export)
(define-key chill-mode-map "\C-cy" 'ch-import)
(define-key chill-mode-map "\C-c{" 'ch-begin-comment)
(define-key chill-mode-map "\C-c}" 'ch-end-comment)
(define-key chill-mode-map "\C-m" 'ch-newline)
(define-key chill-mode-map 'button3 'ch-popup-menu)
(define-key chill-mode-map "\C-c1" 'fume-list-functions)
(define-key chill-mode-map "\C-cg" 'fume-prompt-function-goto)
(define-key chill-mode-map '(shift button3) 'mouse-function-menu)
(define-key chill-mode-map '(meta button1) 'fume-mouse-function-goto)
)
(defun chill-mode ()
"chill-mode: Major mode for editing Chill code
support: indent (needs add. work)
shortcut for standard syntax
tagging
function menu
syntax highlighting
Key bindings:
\\{chill-mode-map}"
(interactive)
(kill-all-local-variables)
(set-syntax-table chill-mode-syntax-table)
(setq major-mode 'chill-mode
mode-name "Chill"
)
(use-local-map chill-mode-map)
(make-local-variable 'current-menubar)
(add-submenu nil chill-mode-menu)
(make-local-variable 'ch-grt-file-ext)
(if (string-match ".ch$" (buffer-name))
(setq ch-grt-file-ext ".grt")
(setq ch-grt-file-ext ""))
(make-local-variable 'parse-sexp-ignore-comments)
(make-local-variable 'indent-line-function)
(make-local-variable 'indent-region-function)
(make-local-variable 'comment-start)
(make-local-variable 'comment-end)
(make-local-variable 'comment-column)
(make-local-variable 'comment-start-skip)
(setq comment-start "/* "
comment-end " */"
comment-column 32
comment-start-skip "/\\*+ *"
parse-sexp-ignore-comments t
indent-line-function 'ch-indent-line
indent-region-function nil)
(run-hooks 'chill-mode-hook))
(defun chill-comment-indent ()
(if (looking-at "^/\\*")
0
(save-excursion
(skip-chars-backward " \t")
(max (1+ (current-column))
comment-column))))
(defconst chill-font-lock-keywords (purecopy
(let ((ident "\\(\\(\\sw\\|\\s_\\)+\\)")
(decl-1 "\\(proc\\|process\\|module\\)")
(decl-2 "\\(syn\\|synmode\\|newmode\\)")
)
(list
(list "\\(<>[^<\n]*<>\\)" 1 'font-lock-comment-face)
(list (concat ident "[ \n\t]*:[ \n\t]*" decl-1)
1
'font-lock-function-name-face t)
(list (concat decl-2 "[ \n\t]+" ident)
2
'font-lock-type-face t)
(list (concat "\\S_\\<\\("
(mapconcat 'identity chill-keywords "\\|")
"\\)\\>\\S_" )
1
'font-lock-keyword-face)
(list (concat "\\S_\\<\\("
(mapconcat 'identity chill-types "\\|")
"\\)\\>\\S_")
1
'font-lock-type-face)
(list (concat "dcl[ \t]+" ident)
1 font-lock-variable-name-face
t)
(list "[^dbhc]'\\([^'\n]*\\)'"
1 'font-lock-string-face
t)
'("^[ \t]*\\(#[ \t]*[^ ]*\\)\\([^\n]*\\)"
(1 font-lock-preprocessor-face)
(2 font-lock-string-face nil t))
)))
"Expressions to highlight in Chill buffers.")
(put 'chill-mode 'font-lock-keywords-case-fold-search t)
(defconst fume-function-name-regexp-chill
"\\(\\(\\sw\\|\\s_\\)+\\)[ \t\n]*:"
"Expression to get CHILL function names
(part before process/proc")
(setq fume-function-name-regexp-alist
(cons '(chill-mode . fume-function-name-regexp-chill)
fume-function-name-regexp-alist))
(setq fume-find-function-name-method-alist
(cons '(chill-mode . fume-find-next-chill-function-name)
fume-find-function-name-method-alist))
(defun fume-find-next-chill-function-name (buffer)
"Searches for the next CHILL function in BUFFER."
(set-buffer buffer)
(catch 'loop
(while (re-search-forward fume-function-name-regexp-chill nil t)
(let ((mb (match-beginning 1))
(me (match-end 1)))
(ch-forward-comment)
(if (looking-at "proc")
(throw 'loop (cons (buffer-substring mb me) mb)))))))
(defun ch-forward-comment ()
"move forward over comments and <> ... <>"
(forward-comment 999)
(if (looking-at "<>\\|#")
(while
(progn
(forward-char 2)
(search-forward-regexp "<>\\|\n" nil t)
(forward-comment 999)
(looking-at "<>\\|#")))))
(defun ch-after-directive ()
"return t if point is after <> "
(or (and (= (preceding-char) ?>)
(= (char-after (- (point) 2)) ?<))
(save-excursion
(beginning-of-line)
(looking-at "[ \t]*#"))))
(defun ch-backward-comment ()
"move backward over comments and <> ... <>"
(forward-comment -999)
(if (ch-after-directive)
(while
(progn
(forward-char -2)
(search-backward-regexp "<>\\|#" nil t)
(forward-comment -999)
(ch-after-directive)))))
(defun ch-newline ()
"Insert a newline and indent following line like previous line."
(interactive)
(if ch-auto-indent
(ch-indent-line))
(insert "\n")
(ch-indent-line))
(defconst ch-indent-plus
"\\b\\(do\\|process\\|proc\\|on\\|case\\|else\\|then\\|begin\\|module\\)\\b\\S_\\|([^)]*):"
"reg expr - indent more")
(defconst ch-indent-minus
"\\b\\(fi\\|od\\|end\\|esac\\|else\\|elsif\\)\\b\\S_\\|([^)]*):"
"reg expr - indent less")
(defun ch-calc-add-indent (from to)
"calc additional indentation between FROM and TO"
(let ((res 0) state)
(goto-char from)
(if (= to (point-max))
(setq to (- to 1)))
(while (<= (point) to)
(setq state (parse-partial-sexp (point) to nil t state))
(let ((plus (looking-at ch-indent-plus))
(minus (looking-at ch-indent-minus)))
(if (or plus minus)
(let ((me (match-end 0)))
(if (and plus (< (point) to))
(setq res (+ res ch-indent)))
(if (and minus (> (point) from))
(setq res (- res ch-indent)))
(setq last-kw me)
(goto-char me)
)
(forward-sexp))))
res))
(defun ch-indent-line ()
"Indent one line"
(let ((eol (eolp)))
(save-excursion
(beginning-of-line)
(delete-horizontal-space)
(if (eolp)
(setq eol t))
(let ((indent-point (point))
(new-indent 0) (last-non-comment 0)
state containing-sexp start-calc
last-kw last-is-semi)
(if (looking-at "<>\\|#")
()
(ch-backward-comment)
(if (or (= (preceding-char) ?\
(= (preceding-char) ?\:))
(progn
(forward-char -1)
(setq last-is-semi t)))
(setq last-non-comment (point))
(while
(progn
(search-backward-regexp ";" nil 0)
(forward-char 1)
(ch-forward-comment)
(beginning-of-line)
(skip-chars-forward " \t")
(looking-at "<>\\|#"))))
(setq start-calc (point))
(setq last-kw start-calc)
(setq new-indent (current-indentation))
(if (> (point) indent-point)
(setq state (list t t t t))
(while (< (point) indent-point)
(setq state (parse-partial-sexp (point) indent-point))
(setq containing-sexp (car (cdr state)))))
(goto-char indent-point)
(cond
((or (nth 3 state)
(nth 4 state))
(search-backward "/*" nil t)
(setq new-indent (current-column))
(setq last-is-semi t))
(containing-sexp (goto-char (+ containing-sexp 1))
(skip-chars-forward " \t")
(setq new-indent (current-column))
(setq last-is-semi t)
(if (and (search-forward-regexp "IN[ \t]+"
indent-point t)
(save-excursion
(up-list 1)
(looking-at ":")))
(setq new-indent (current-column))))
(t (setq new-indent (+ new-indent
(ch-calc-add-indent start-calc
indent-point)))))
(goto-char indent-point)
(if last-is-semi
()
(if (>= last-kw last-non-comment)
()
(goto-char start-calc)
(if (search-forward-regexp "\\(:=\\|\\<if\\|\\<with\\)[ \t]+"
indent-point t)
(setq new-indent (current-column))
(setq new-indent (+ new-indent ch-indent)))
(goto-char indent-point)))
(indent-to new-indent)))
(if eol
(end-of-line))))
(defun ch-electric-char (arg)
"Insert a character and indent line"
(interactive "P")
(self-insert-command (prefix-numeric-value arg))
(if ch-auto-indent
(ch-indent-line)))
(defun ch-buffer-name-no-ext ()
"Returns the name of the current buffer without extension"
(substring (buffer-name)
(string-match "\\(\\sw\\|\\s_\\)*.*"
(buffer-name))
(match-end 1)))
(defun ch-get-name (prompt)
"get one name (using TAGS)"
(let ((completion-ignore-case t)
(def (find-tag-tag prompt)))
(if (listp def)
(car def)
def)))
(defun ch-read-parameter ()
"Returns nil for no parameter or a list of (name spec type name spec ...)"
(catch 'loop
(let ((parms))
(while
(let ((name (read-string "Paramtername: ")))
(if (string-equal name "")
(throw 'loop parms))
(let ((mode (ch-get-name "Mode: "))
(spec (completing-read
"Spec: "
'(("IN" 0) ("OUT" 1) ("INOUT" 1) ("LOC" 1) ("" 2))
nil t "IN")))
(if parms
(setq parms (nconc parms (list name mode spec)))
(setq parms (list name mode spec)))))))))
(defun ch-insert-parameter (para header fill1 fill2)
"insert list of parameters PARA (from ch-read-parameter),
insert: HEADER name FILL1 mode FILL1 spec FILL2 mode ... spec"
(if (not para)
()
(insert header)
(while
(progn
(insert (car para) fill1)
(setq para (cdr para))
(insert (car para) fill1)
(setq para (cdr para))
(insert (car para))
(setq para (cdr-safe para))
(if para
(insert fill2))
para))))
(defun ch-begin ()
"Insert a BEGIN keyword and indent for the next line."
(interactive)
(insert "BEGIN")
(ch-newline)
(save-excursion
(ch-newline)
(insert "END;")
(ch-indent-line))
(ch-indent-line))
(defun ch-case ()
"Build skeleton CASE statement, prompting for the <expression>."
(interactive)
(let ((name (read-string "Case-Expression: ")))
(insert "CASE " name " OF")
(ch-newline)
(ch-newline)
(insert "ELSE")
(ch-newline)
(ch-newline)
(insert "ESAC; /* case " name " */")
(ch-indent-line))
(end-of-line -2)
(ch-indent-line))
(defun ch-definition ()
"Build skeleton MODULE, prompting for the <module name>."
(interactive)
(let* ((guess (substring (buffer-name)
(string-match "\\(\\sw\\|\\s_\\)*.*"
(buffer-name))
(match-end 1) ) )
(name (read-string "Name: " (concat guess "_md") )))
(insert name " : MODULE\n\n")
(ch-header)
(insert "\n<> DEBUG_LINES <>"
"\n<> DEBUG_SYMBOLS <>"
"\n<> DEBUG_TYPES <>"
"\n<> MAKE_PUBLICS_FOR_DISCRETE_SYNS <>"
"\n<> SUPPORT_CAUSING_ADDRESS <>"
"\n<> LARGE <>"
"\n<> EVEN <>"
"\n<> SEND_SIGNAL_DEFAULT_PRIORITY=1<>")
(insert "\n\n\nEND " name ";\n"))
(previous-line 3)
(ch-indent-line))
(defun ch-else ()
"Insert ELSE keyword and indent for next line."
(interactive)
(insert "ELSE")
(ch-indent-line)
(insert "\n\n")
(end-of-line 0)
(ch-indent-line))
(defun ch-for ()
"Build skeleton DO FOR loop statement, prompting for the loop parameters."
(interactive)
(let ((name (read-string "Loop Variable: "))
(from (read-string "From/In: "))
(to (read-string "To: "))
(whilex (read-string "While: "))
(start (point)))
(insert "DO FOR ")
(if (string-equal to "")
(insert name " IN " from )
(insert name " := " from " TO " to))
(if (not (string-equal whilex ""))
(insert " WHILE " whilex))
(insert ";\n")
(save-excursion
(if (string-equal to "")
(insert "\nOD; /* for " name " in " from)
(insert "\nOD; /* for " name " := " from " to " to ))
(insert " */")
(indent-region start (point) nil))
(ch-indent-line)))
(defun ch-header ()
"Insert a comment block containing the module title, author, etc."
(interactive)
(insert "/*")
(insert "\n----------------------------------------------------------------")
(insert "\n-- $Id: chill-mode.el,v 1.1 2001/11/19 22:59:32 hoerandl Exp $\n--")
(insert "\n-- Title: \t")
(insert (read-string "Title: " (ch-buffer-name-no-ext)))
(insert "\n-- File:\t")
(insert (buffer-name))
(insert "\n-- Created:\t")
(insert (current-time-string))
(insert "\n-- Author: \t" (user-full-name))
(insert (concat "\t<" (user-login-name) ">"))
(insert "\n--\n--\n-- Abstract:")
(insert "\n--\n--")
(insert "\n-- Modifications:")
(insert "\n-- $Log: chill-mode.el,v $
(insert "\n-- Revision 1.1 2001/11/19 22:59:32 hoerandl
(insert "\n-- initial release
(insert "\n--")
(insert "\n--")
(insert "\n----------------------------------------------------------------")
(insert "\n*/\n\n"))
(defun ch-if ()
"Insert skeleton IF statment, prompting for <boolean-expression>."
(interactive)
(insert "IF ")
(let ((thecondition (read-string "<boolean-expression>: ")))
(insert "( " thecondition " )")
(ch-newline)
(insert "THEN")
(ch-newline)
(save-excursion
(ch-newline)
(insert "FI
(ch-indent-line))
(ch-indent-line)))
(defun ch-elsif ()
"Insert skeleton ELSIF statment, prompting for <boolean-expression>."
(interactive)
(insert "ELSIF ")
(let ((thecondition (read-string "<boolean-expression>: ")))
(insert thecondition "\nTHEN")
(ch-newline)
(ch-newline))
(end-of-line 0)
(ch-indent-line))
(defun ch-or ()
(interactive)
(ch-newline)
(backward-delete-char-untabify ch-indent)
(insert "OR")
(ch-newline)
(ch-indent-line))
(defun ch-procedure ()
(interactive)
(let ((name (read-string "Procedure: " ))
(args (ch-read-parameter))
(returns (read-string "Result Type: "))
(handler (y-or-n-p "END ON ELSE: "))
(grant (y-or-n-p "Grant: "))
(start (point)))
(insert "/*")
(insert "\n----------------------------------------------------------------")
(insert "\n--")
(insert "\n-- PROCEDURE " name)
(insert "\n--")
(ch-insert-parameter args "\n-- Parameter " "\t" "\n-- ")
(if (not (string-equal returns ""))
(insert "\n--\n-- RETURNS ( " returns " )"))
(insert "\n--")
(insert "\n----------------------------------------------------------------")
(insert "\n*/\n\n")
(insert name ": PROC ( ")
(ch-insert-parameter args "" "\t" "\n")
(insert ")")
(if (not (string-equal returns ""))
(insert "\n RETURNS ( " returns " )"))
(insert ";\n\n")
(save-excursion
(insert "\n")
(if handler
(insert ch-proc-end-on-else-handler))
(insert "\nEND ")
(insert name)
(insert ";")
(if grant
(insert "\n\nGRANT " name ";"))
(indent-region start (point) nil))
(ch-indent-line)
(end-of-line)))
(defun ch-process ()
(interactive)
(let* ((guess (ch-buffer-name-no-ext) )
(name (read-string "Process: " guess))
(args (ch-read-parameter))
(handler (y-or-n-p "END ON ELSE: "))
(start (point)))
(insert "/*")
(insert "\n----------------------------------------------------------------")
(insert "\n--")
(insert "\n-- PROCESS " name)
(insert "\n--")
(ch-insert-parameter args "\n-- Parameter " "\t" "\n-- ")
(insert "\n--")
(insert "\n----------------------------------------------------------------")
(insert "\n*/\n\n")
(insert "<> PROCESS_TYPE = sy_pr_" name " <>\n")
(insert name ": PROCESS ( ")
(ch-insert-parameter args "" "\t" "\n")
(insert ");\n\n")
(save-excursion
(insert "\n")
(if handler
(insert ch-proc-end-on-else-handler))
(insert "\nEND ")
(insert name)
(insert ";")
(insert "\n\nGRANT " name ";")
(indent-region start (point) nil))
(ch-indent-line)
(end-of-line)))
(defun ch-with ()
(interactive)
(let ((start (point))
(name (read-string "DO WITH Record-Type: ")))
(insert "DO WITH " name ";\n")
(save-excursion
(insert "\nOD; /* with " name " */\n")
(indent-region start (point) nil))
(ch-indent-line)))
(defun ch-mode ()
(interactive)
(insert "NEWMODE =")
(ch-newline)
(ch-indent-line))
(defun ch-var ()
(interactive)
(ch-newline)
(insert "DCL")
(ch-newline)
(ch-indent-line))
(defun ch-while ()
(interactive)
(let ((start (point))
(name (read-string "DO WHILE <boolean-expression>: ")))
(insert "DO WHILE " name ";\n" )
(save-excursion
(insert "\nOD; /* while " name " */\n")
(indent-region start (point) nil))
(ch-indent-line)))
(defun ch-begin-comment ()
(interactive)
(if (not (bolp))
(indent-to comment-column 0))
(insert "/* "))
(defun ch-end-comment ()
(interactive)
(if (not (bolp))
(indent-to comment-column))
(insert "*/"))
(defun ch-line-comment ()
(interactive)
(if (not (bolp))
(indent-to comment-column 0))
(insert "-- "))
(defun ch-add-comment ()
(interactive)
(let ((start (point)))
(insert "/*\n"
"--------------------------------------------------------------"
"\n--"
"\n-- ")
(save-excursion
(insert "\n--"
"\n--------------------------------------------------------------"
"\n*/\n")
(indent-region start (point) nil))))
(defun ch-get-record ()
(interactive)
(let ((relation (ch-get-name "Relation: "))
(num (read-string "Nummer: "))
(buff (read-string "Buffer: "))
(sel (read-string "Selector: "))
(start (point)))
(insert "GET_RECORD( " relation ",\n"
num ",\n"
"ADDR(" buff "), SIZE(" buff "),\n"
sel ",\n"
"sy_db_no_wait );\n")
(indent-region start (point) nil)
(ch-indent-line)))
(defun ch-start-signal-timeout ()
(interactive)
(let ((slot (read-string "Slot: " "sy_lpr_slot"))
(tocl (read-string "Zeitklasse: " "sy_class_"))
(dur (read-string "Dauer: "))
(sig (ch-get-name "Signal: "))
(start (point)))
(insert "START_SIGNAL_TIMEOUT( " slot ",\n"
" " tocl ",\n"
dur ",\n"
sig ");\n")
(indent-region start (point) nil)
(ch-indent-line)))
(defun ch-insert-global-symbol ()
"Insert Symbol (using TAGS)"
(interactive)
(let ((name (ch-get-name "Symbol: "))
(seize (y-or-n-p "Seize: ")))
(insert name)
(if seize
(ch-insert-seize))))
(defun ch-receive-signal ()
(interactive)
(let ((sig (ch-get-name "Signal: "))
(syn (read-string "Syn: " ))
(var (read-string "Variablen: "))
(from (ch-get-name "From: "))
(start (point)))
(insert "/*")
(insert "\n----------------------------------------------------------------")
(insert "\n-- Signal: " sig)
(insert "\n--")
(if (not (string-equal syn ""))
(insert "\n-- " syn))
(insert "\n--")
(if (not (string-equal from ""))
(if (not (string-equal from "THIS"))
(insert "\n-- from: " from)))
(insert "\n--")
(insert "\n----------------------------------------------------------------")
(insert "\n*/\n")
(insert " (" sig )
(if (not (string-equal var ""))
(insert " IN " var ))
(insert "):\n" )
(if (not (string-equal from ""))
(progn
(if (string-equal from "THIS")
(insert "\nIF ( vp_sender /= THIS )")
(insert "\nIF ( PROC_TYPE (vp_sender) /= " from " )"))
(insert "\nTHEN"
"\n;"
"\nFI;\n")))
(insert "\n")
(indent-region start (point) nil)
(ch-indent-line)))
(defun ch-message-loop ()
(interactive)
(let ((start (point)))
(insert "\nDCL vp_sender INSTANCE;"
"\n\nDO FOR EVER;"
"\n\nl_receive:"
"\nRECEIVE CASE SET vp_sender;"
"\n\n\n/*"
"\n----------------------------------------------------------------"
"\n--"
"\n-- ELSE (RECEIVE Signal)"
"\n--"
"\n----------------------------------------------------------------"
"\n*/"
"\nELSE"
"\n;"
"\nESAC; /*=== RECEIVE CASE ===*/"
"\n\nOD; /*=== DO FOR EVER ===*/"
"\n")
(indent-region start (point) nil)
(ch-indent-line)))
(defun ch-insert-seize ()
"Insert seize statement for TAGNAME (requires valid TAGS table)
uses ch-grt-file-ext as an extension for the grant file"
(interactive)
(let* ((tagname (ch-get-name "Insert seize for: "))
(seize-text (concat "seize[ \t]*" tagname "[ ,;]")))
(save-window-excursion
(save-excursion
(message "Looking for '%s' ..." tagname)
(widen)
(goto-char (point-min))
(if (search-forward-regexp seize-text nil t )
(message "'%s' already seized" tagname)
(let* ((bn (save-excursion
(find-tag (list tagname))
(ch-buffer-name-no-ext)))
(ust (concat "use_seize_file[ \t]*'" bn )))
(if (search-forward-regexp ust nil t)
(progn
(message "'%s' seized from '%s'" tagname bn)
(forward-line 1)
(insert " SEIZE " tagname ";\n")
)
(progn
(message "'%s' seized from new file '%s'" tagname bn)
(search-forward "use_seize_file" nil t)
(beginning-of-line)
(insert "<> USE_SEIZE_FILE '" bn ch-grt-file-ext "' <>\n"
" SEIZE " tagname ";\n\n")))))))))
(defun chill-downcase-keywords ()
"Downcase all Chill keywords in the buffer."
(interactive)
(chill-change-keywords 'downcase-word chill-keywords))
(defun chill-upcase-keywords ()
"Upcase all Chill keywords in the buffer."
(interactive)
(chill-change-keywords 'upcase-word chill-keywords))
(defun chill-capitalize-keywords ()
"Capitalize all Chill keywords in the buffer."
(interactive)
(chill-change-keywords 'capitalize-word chill-keywords))
(defun chill-downcase-types ()
"Downcase all Chill types in the buffer."
(interactive)
(chill-change-keywords 'downcase-word chill-types))
(defun chill-upcase-types ()
"Upcase all Chill types in the buffer."
(interactive)
(chill-change-keywords 'upcase-word chill-types))
(defun chill-capitalize-types ()
"Capitalize all Chill types in the buffer."
(interactive)
(chill-change-keywords 'capitalize-word chill-types))
(defun chill-change-keywords (change-word expr)
(save-excursion
(let ((keyword-re (concat "\\S_\\<\\("
(mapconcat 'identity expr "\\|")
"\\)\\>\\S_")))
(goto-char (point-min))
(while (re-search-forward keyword-re nil t)
(progn
(funcall change-word -1)
(backward-char 1))))))
(defvar chill-buffer-to-use nil)
(defvar chill-flag nil)
(defvar chill-all nil)
(defvar chill-str nil)
(defun chill-string-diff (str1 str2)
"Return index of first letter where STR1 and STR2 differs."
(catch 'done
(let ((diff 0))
(while t
(if (or (> (1+ diff) (length str1))
(> (1+ diff) (length str2)))
(throw 'done diff))
(or (equal (aref str1 diff) (aref str2 diff))
(throw 'done diff))
(setq diff (1+ diff))))))
(defun chill-get-default-symbol ()
"Return symbol around current point as a string."
(save-excursion
(buffer-substring (progn
(skip-chars-backward " \t")
(skip-chars-backward "a-zA-Z0-9_")
(point))
(progn
(skip-chars-forward "a-zA-Z0-9_")
(point)))))
(defun chill-completion-response ()
(cond ((or (equal chill-flag 'lambda) (null chill-flag))
(if (null chill-all)
nil
(let* ((elm (cdr chill-all))
(match (car chill-all))
(min (length match))
tmp)
(if (string= match chill-str)
(setq match t)
(while (not (null elm))
(if (< (setq tmp (chill-string-diff match (car elm))) min)
(progn
(setq min tmp)
(setq match (substring match 0 min))))
(if (string= (car elm) chill-str)
(progn
(setq match t)
(setq elm nil))
(setq elm (cdr elm)))))
(if (and (equal chill-flag 'lambda) (not (equal match 't)))
nil
match))))
(chill-flag
chill-all)))
(defun chill-build-PROC-re (str &optional arg)
"Return PROC starting with STR as regular expression.
With optional second arg non-nil, STR is the complete name of the instruction."
(if arg
(concat "^[ \t]*\\(" str "\\)\\>[ \t]*:[ \t]*\\<\\(MODULE\\|PROCESS\\|PROC\\)\\>")
(concat "^[ \t]*\\(" str "[a-zA-Z0-9_]*\\)\\>[ \t]*:[ \t]*\\<\\(MODULE\\|PROCESS\\|PROC\\)\\>")
)
)
(defun chill-comp-PROC (chill-str chill-pred chill-flag)
(save-excursion
(let ((chill-all nil)
match)
(set-buffer chill-buffer-to-use)
(let ((chill-str chill-str))
(if (string= chill-str "")
(setq chill-str (chill-build-PROC-re "[a-zA-Z_]"))
(setq chill-str (chill-build-PROC-re chill-str)))
(goto-char (point-min))
(while (re-search-forward chill-str nil t)
(setq match (buffer-substring (match-beginning 1) (match-end 1)))
(if (or (null chill-pred)
(funcall chill-pred match))
(setq chill-all (cons match chill-all)))))
(chill-completion-response))))
(defun chill-goto-PROC ()
"Move to specified Chill function/procedure.
The default is a name found in the buffer around point."
(interactive)
(let* ((default (chill-get-default-symbol))
(chill-buffer-to-use (current-buffer))
(default (if (chill-comp-PROC default nil 'lambda)
default ""))
(label (if (not (string= default ""))
(completing-read (concat "Name: (default " default ") ")
'chill-comp-PROC nil t "")
(completing-read "Name: "
'chill-comp-PROC nil t "")))
)
(if (string= label "")
(setq label default))
(or (string= label "")
(progn
(goto-char (point-min))
(re-search-forward (chill-build-PROC-re label t))
(beginning-of-line)))
))
(defun chill-build-DCL-re (str &optional arg)
"Return DCL starting with STR as regular expression.
With optional second arg non-nil, STR is the complete name of the instruction."
(if arg
(concat "^[ \t]*\\(DCL\\|SYN\\|SYNMODE\\|NEWMODE\\)[ \t]+\\(" str "\\)\\>")
(concat "^[ \t]*\\(DCL\\|SYN\\|SYNMODE\\|NEWMODE\\)[ \t]+\\(" str "[a-zA-Z0-9_]*\\)\\>")
)
)
(defun chill-comp-DCL (chill-str chill-pred chill-flag)
(save-excursion
(let ((chill-all nil)
match)
(set-buffer chill-buffer-to-use)
(let ((chill-str chill-str))
(if (string= chill-str "")
(setq chill-str (chill-build-DCL-re "[a-zA-Z_]"))
(setq chill-str (chill-build-DCL-re chill-str)))
(goto-char (point-min))
(while (re-search-forward chill-str nil t)
(setq match (buffer-substring (match-beginning 2) (match-end 2)))
(if (or (null chill-pred)
(funcall chill-pred match))
(setq chill-all (cons match chill-all)))))
(chill-completion-response))))
(defun chill-goto-DCL ()
"Move to specified Chill function/procedure.
The default is a name found in the buffer around point."
(interactive)
(let* ((default (chill-get-default-symbol))
(chill-buffer-to-use (current-buffer))
(default (if (chill-comp-DCL default nil 'lambda)
default ""))
(label (if (not (string= default ""))
(completing-read (concat "Name: (default " default ") ")
'chill-comp-DCL nil t "")
(completing-read "Name: "
'chill-comp-DCL nil t "")))
)
(if (string= label "")
(setq label default))
(or (string= label "")
(progn
(re-search-backward (chill-build-DCL-re label t))
(beginning-of-line)))
))
(defun start-gdb-other-window ()
"start gdb in other window"
(interactive)
(let ((name (ch-buffer-name-no-ext)))
(delete-other-windows)
(split-window-vertically)
(other-window 1)
(gdb name)))
(defun start-gdb-other-window-and-run ()
"start gdb in other window and run to current line"
(interactive)
(start-gdb-other-window)
(other-window 1)
(gdb-break nil)
(other-window 1)
(insert "run")
(comint-send-input))
(setq auto-mode-alist (cons '("\\.ch$" . chill-mode) auto-mode-alist))
(setq auto-mode-alist (cons '("\\.chill$" . chill-mode) auto-mode-alist))
(provide 'chill-mode)