/[ascend]/trunk/emacsMode/ascend-mode.el
ViewVC logotype

Annotation of /trunk/emacsMode/ascend-mode.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 229 - (hide annotations) (download)
Sat Jan 28 16:29:08 2006 UTC (17 years ago) by aw0a
File size: 50824 byte(s)
committed files that add ASCEND mode to the emacs editor
1 aw0a 229 ;;; ascend-mode.el, a mode for editing ASCEND code in emacs
2     ;;;
3     ;;; This file is part of the Ascend modeling library.
4     ;;;
5     ;;; Copyright (C) 1994,1995,1996,1997,1998
6     ;;;
7     ;;; Carnegie Mellon University
8     ;;;
9     ;;; The Ascend modeling library is free software; you can redistribute it
10     ;;; and/or modify it under the terms of the GNU General Public License as
11     ;;; published by the Free Software Foundation; either version 2 of the
12     ;;; License, or (at your option) any later version.
13     ;;;
14     ;;; The Ascend Language Interpreter is distributed in hope that it will
15     ;;; be useful, but WITHOUT ANY WARRANTY; without even the implied
16     ;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See
17     ;;; the GNU General Public License for more details.
18     ;;;
19     ;;; You should have received a copy of the GNU General Public License
20     ;;; along with the program; if not, write to the Free Software
21     ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the
22     ;;; file named COPYING.
23     ;;;
24     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25     ;;;
26     ;;; 1994 Aug 26 Mark Thomas <mthomas+@cmu.edu>
27     ;;; - Initial version created in Lucid Emacs 19.10
28     ;;;
29     ;;; 1995 Sep 13 Mark Thomas <mthomas+@cmu.edu>
30     ;;; - Updated for use with XEmacs 19.12
31     ;;; - Added functions to support Gnu Emacs Menus
32     ;;;
33     ;;; 1996 May 29 Mark Thomas <mthomas+@cmu.edu>
34     ;;; - Changing keywords:
35     ;;; * INITIALIZATION --> METHODS
36     ;;; * PROCEDURE --> METHOD
37     ;;;
38     ;;; 1997 Nov Mark Thomas <mthomas+@cmu.edu>
39     ;;; - Major rewrite to make ascend-mode compatible with the
40     ;;; latest releases of
41     ;;; * ASCEND IV (0.8)
42     ;;; * XEmacs (19.16)
43     ;;; * FSF Emacs (19.34)
44     ;;; - Most of the code was made more general to be easily
45     ;;; expandable as ASCEND IV grows
46     ;;;
47     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48     ;;;
49     ;;; Make sure we get the 'cl package
50     ;;;
51     (require 'cl)
52     ;;;
53     ;;; User Friendly Constants -------------------------------------------------
54     ;;;
55    
56     (defvar ascend-block-indent-level 4
57     "*Indentation of ASCEND statements in a block with respect to the
58     statement that starts the block.")
59    
60     (defvar ascend-continuation-indent-level 4
61     "*Indentation of ASCEND statement continuations with respect to
62     statement start. CURRENTLY NOT SUPPORTED.")
63    
64     (defvar ascend-auto-newline nil
65     "*If nonnil, a newline is automatically inserted when semicolon(;)
66     is entered. Implies ascend-semicolon-auto-indent.")
67    
68     (defvar ascend-semicolon-auto-indent t
69     "*If nonnil, entering a semicolon(;) will always indent the current
70     line.")
71    
72     (defvar ascend-auto-add-end-statement t
73     "*If nonnil, pressing RETURN \(or semicolon if ascend-auto-newline
74     is nonnil\) on a line that starts a block will cause the matching end
75     statement to be automatically added to the buffer.")
76    
77     (defvar ascend-tab-always-indent nil
78     "*If nonnil, pressing TAB will always indent the current line;
79     otherwise, TAB will only indent if in the left margin.")
80    
81     (defvar ascend-expand-abbrevs-in-comments nil
82     "If nil, abbrevs are not expanded in comments, strings, and
83     notes.")
84    
85     (defvar ascend-mode-hook nil
86     "*Mode hook for ASCEND mode buffers.")
87    
88     ;;;
89     ;;; Internal Variables ------------------------------------------------------
90     ;;;
91    
92     (defvar ascend-abbrev-table nil
93     "Abbrev table for use in ascend-mode buffers")
94    
95     (defvar ascend-mode-map nil
96     "Keymap for use in ascend-mode buffers")
97    
98     (defvar ascend-mode-syntax-table nil
99     "Syntax table for use in ascend-mode buffers")
100    
101     (defvar ascend-font-lock-keywords nil
102     "ASCEND keywords for font-lock mode.
103     See the documentation for font-lock-keywords.")
104    
105     (defvar ascend-menu nil
106     "A menu for ASCEND mode buffers.")
107    
108     (defconst ascend-mode-version "1.14"
109     "Version number for this release of ASCEND mode.")
110    
111     ;;;
112     ;;; Do the actual dirty deed ------------------------------------------------
113     ;;;
114    
115     ;;; ABBREV TABLE
116     ;;; abbrev-list is a list of sub-lists; the car of each sublist is
117     ;;; the expansion text; the cdr are the strings that expand into
118     ;;; that text.
119     (if (not ascend-abbrev-table)
120     (let ((abbrev-list '(("ADD" "add")
121     ("ALIASES" "aliases" "alii" "al")
122     ("AND" "and")
123     ("ANY" "any")
124     ("ARE_ALIKE" "are_alike" "arealike" "aa")
125     ("ARE_THE_SAME" "are_the_same" "arethesame" "ats")
126     ("ARRAY" "array")
127     ("ATOM" "atom")
128     ("BREAK" "break")
129     ("CALL" "call")
130     ("CARD" "card")
131     ("CASE" "case")
132     ("CHOICE" "choice")
133     ("CONDITIONAL" "conditional")
134     ("CONSTANT" "constant" "const")
135     ("CONTINUE" "continue")
136     ("CREATE" "create")
137     ("DATA" "data")
138     ("DECREASING" "descreasing")
139     ("DEFAULT" "default")
140     ("DEFINITION" "definition")
141     ("DIMENSION" "dimension")
142     ("DIMENSIONLESS" "dimensionless")
143     ("DO" "do")
144     ("ELSE" "else")
145     ("END" "end")
146     ("EXTERNAL" "external")
147     ("FALSE" "false")
148     ("FALL_THROUGH" "fall_through" "fallthrough" "fall")
149     ("FOR" "for")
150     ("FROM" "from")
151     ("GLOBAL" "global")
152     ("IF" "if")
153     ("IMPORT" "import")
154     ("IN" "in")
155     ("INCREASING" "increasing")
156     ("INPUT" "input")
157     ("INTERACTIVE" "interactive")
158     ("INTERSECTION" "intersection")
159     ("IS_A" "is_a" "isa")
160     ("IS_REFINED_TO" "is_refined_to" "isrefinedto" "irt")
161     ("MAXIMIZE" "maximize" "max")
162     ("MAX_INTEGER" "max_integer" "maxinteger" "maxint")
163     ("MAX_REAL" "max_real" "maxreal")
164     ("METHOD" "method")
165     ("METHODS" "methods")
166     ("MINIMIZE" "minimize" "min")
167     ("MODEL" "model")
168     ("NOT" "not")
169     ("NOTES" "notes")
170     ("OF" "of")
171     ("OR" "or")
172     ("OTHERWISE" "otherwise")
173     ("OUTPUT" "output")
174     ("PROD" "prod")
175     ("PROVIDE" "provide")
176     ("REFINES" "refines")
177     ("REPLACE" "replace")
178     ("REQUIRE" "require")
179     ("RETURN" "return")
180     ("RUN" "run")
181     ("SATISFIED" "satisfied")
182     ("SELECT" "select")
183     ("SIZE" "size")
184     ("STOP" "stop")
185     ("SUCH_THAT" "such_that" "suchthat")
186     ("SUM" "sum")
187     ("SWITCH" "switch")
188     ("THEN" "then")
189     ("TRUE" "true")
190     ("UNION" "union")
191     ("UNITS" "units")
192     ("UNIVERSAL" "universal")
193     ("USE" "use")
194     ("VALUE" "value")
195     ("WHEN" "when")
196     ("WHERE" "where")
197     ("WHILE" "while")
198     ("WILL_BE" "will_be" "willbe" "wb")
199     ("WILL_BE_THE_SAME" "willbethesame" "wbts")
200     ("WILL_NOT_BE_THE_SAME" "willnotbethesame" "wnbts")
201     ("WITH" "with")
202     ("WITH_VALUE" "with_value" "withvalue" "wv"))
203     ))
204     (define-abbrev-table 'ascend-abbrev-table ())
205     (mapcar '(lambda (abbrev)
206     (let ((expansion (car abbrev)))
207     (mapcar '(lambda (name)
208     (define-abbrev ascend-abbrev-table
209     name
210     expansion
211     'ascend-undo-abbrev-in-comment))
212     (cdr abbrev))))
213     abbrev-list)))
214    
215    
216    
217     ;;; MODE MAP
218     ;;; The ascend-mode-map is minimal.
219     (if (not ascend-mode-map)
220     (progn
221     (setq ascend-mode-map (make-sparse-keymap))
222     (define-key ascend-mode-map "\t" 'electric-ascend-tab)
223     (define-key ascend-mode-map "\C-m" 'electric-ascend-newline-indent)
224     (define-key ascend-mode-map "\C-j" 'electric-ascend-newline)
225     (define-key ascend-mode-map ";" 'electric-ascend-semicolon)
226     (define-key ascend-mode-map "\M-\C-b" 'ascend-backward-block)
227     (define-key ascend-mode-map "\M-\C-f" 'ascend-forward-block)
228     (define-key ascend-mode-map "\M-\C-a" 'ascend-beginning-of-block)
229     (define-key ascend-mode-map "\M-\C-e" 'ascend-end-of-block)
230     (define-key ascend-mode-map "\M-\C-h" 'ascend-mark-block)
231     ))
232    
233    
234    
235     ;;; SYNTAX TABLE
236     ;;; For the syntax table, we have to make the math characters into
237     ;;; punctuation and define the comment characters. We make braces
238     ;;; into matching string delimiters when running under XEmacs
239     (if (not ascend-mode-syntax-table)
240     (progn
241     (setq ascend-mode-syntax-table (make-syntax-table))
242     ;; the following are the same as the (standard-syntax-table)
243     ;;(modify-syntax-entry ?\\ "\\" ascend-mode-syntax-table)
244     ;;(modify-syntax-entry ?\" "\"" ascend-mode-syntax-table)
245     ;;(modify-syntax-entry ?\t " " ascend-mode-syntax-table)
246     ;;(modify-syntax-entry ?\n " " ascend-mode-syntax-table)
247     ;;(modify-syntax-entry ?\r " " ascend-mode-syntax-table)
248     ;;(modify-syntax-entry ?\f " " ascend-mode-syntax-table)
249     ;;(modify-syntax-entry ?\v " " ascend-mode-syntax-table)
250     ;;(modify-syntax-entry ?\[ "(]" ascend-mode-syntax-table)
251     ;;(modify-syntax-entry ?\] ")[" ascend-mode-syntax-table)
252     ;;(modify-syntax-entry ?\{ "<}" ascend-mode-syntax-table)
253     ;;(modify-syntax-entry ?\} ">{" ascend-mode-syntax-table)
254     ;;
255     ;; the following differ from the (standard-syntax-table)
256     (modify-syntax-entry ?\( "()1" ascend-mode-syntax-table)
257     (modify-syntax-entry ?\) ")(4" ascend-mode-syntax-table)
258     (modify-syntax-entry ?* ". 23" ascend-mode-syntax-table)
259     (modify-syntax-entry ?+ "." ascend-mode-syntax-table)
260     (modify-syntax-entry ?- "." ascend-mode-syntax-table)
261     (modify-syntax-entry ?= "." ascend-mode-syntax-table)
262     (modify-syntax-entry ?% "." ascend-mode-syntax-table)
263     (modify-syntax-entry ?\/ "." ascend-mode-syntax-table)
264     (modify-syntax-entry ?^ "." ascend-mode-syntax-table)
265     (modify-syntax-entry ?< "." ascend-mode-syntax-table)
266     (modify-syntax-entry ?> "." ascend-mode-syntax-table)
267     (modify-syntax-entry ?& "." ascend-mode-syntax-table)
268     (modify-syntax-entry ?| "." ascend-mode-syntax-table)
269     (modify-syntax-entry ?. "." ascend-mode-syntax-table)
270     (modify-syntax-entry ?, "." ascend-mode-syntax-table)
271     ;; treat _ as a word for abbrev mode and for search strings. If
272     ;; _ is not a word char, then when sitting on the b in foo_bar
273     ;; (looking-at "\\<") returns t
274     (modify-syntax-entry ?_ "w" ascend-mode-syntax-table)
275     (modify-syntax-entry ?' "\"" ascend-mode-syntax-table)
276     ;; treat braces as matching string delimters in XEmacs
277     (if (string-match "XEmacs" emacs-version)
278     (progn
279     (modify-syntax-entry ?\{ "\"}" ascend-mode-syntax-table)
280     (modify-syntax-entry ?\} "\"{" ascend-mode-syntax-table)))
281     ))
282    
283    
284     ;;; FONT LOCK
285     ;;; The font lock stuff looks a lot worse than it is...
286     (if ascend-font-lock-keywords
287     ()
288     (let* ((keywords '("ADD"
289     "ALIASES"
290     "AND"
291     "ANY"
292     "ARE_ALIKE"
293     "ARE_THE_SAME"
294     "ARRAY"
295     "ATOM"
296     "BREAK"
297     "CALL"
298     "CARD"
299     "CASE"
300     "CHOICE"
301     "CONDITIONAL"
302     "CONSTANT"
303     "CONTINUE"
304     "CREATE"
305     "DATA"
306     "DECREASING"
307     "DEFAULT"
308     "DEFINITION"
309     "DIMENSION"
310     "DIMENSIONLESS"
311     "DO"
312     "ELSE"
313     "END"
314     "EXTERNAL"
315     "FALSE"
316     "FALL_THROUGH"
317     "FOR"
318     "FROM"
319     "GLOBAL"
320     "IF"
321     "IMPORT"
322     "IN"
323     "INCREASING"
324     "INPUT"
325     "INTERACTIVE"
326     "INTERSECTION"
327     "IS_A"
328     "IS_REFINED_TO"
329     "MAXIMIZE"
330     "MAX_INTEGER"
331     "MAX_REAL"
332     "METHOD"
333     "METHODS"
334     "MINIMIZE"
335     "MODEL"
336     "NOT"
337     "NOTES"
338     "OF"
339     "OR"
340     "OTHERWISE"
341     "OUTPUT"
342     "PROD"
343     "PROVIDE"
344     "REFINES"
345     "REPLACE"
346     "REQUIRE"
347     "RETURN"
348     "RUN"
349     "SATISFIED"
350     "SELECT"
351     "SIZE"
352     "STOP"
353     "SUCH_THAT"
354     "SUM"
355     "SWITCH"
356     "THEN"
357     "TRUE"
358     "UNION"
359     "UNITS"
360     "UNIVERSAL"
361     "USE"
362     "VALUE"
363     "WHEN"
364     "WHERE"
365     "WHILE"
366     "WILL_BE"
367     "WILL_BE_THE_SAME"
368     "WILL_NOT_BE_THE_SAME"
369     "WITH"
370     "WITH_VALUE"))
371     (keyword-regexp
372     (if (fboundp 'make-regexp)
373     (concat "\\<" (make-regexp keywords t) "\\>")
374     (concat "\\<\\(A\\(DD\\|LIASES\\|N[DY]\\|R\\(E_\\(ALIKE\\|"
375     "THE_SAME\\)\\|RAY\\)\\|TOM\\)\\|BREAK\\|C\\(A\\(LL"
376     "\\|RD\\|SE\\)\\|HOICE\\|ON\\(DITIONAL\\|STANT\\|"
377     "TINUE\\)\\|REATE\\)\\|D\\(ATA\\|E\\(CREASING\\|F"
378     "\\(AULT\\|INITION\\)\\)\\|IMENSION\\(\\|LESS\\)\\|O"
379     "\\)\\|E\\(LSE\\|ND\\|XTERNAL\\)\\|F\\(AL\\(L_THROUGH"
380     "\\|SE\\)\\|OR\\|ROM\\)\\|GLOBAL\\|I\\([FN]\\|MPORT"
381     "\\|N\\(CREASING\\|PUT\\|TER\\(ACTIVE\\|SECTION\\)\\)"
382     "\\|S_\\(A\\|REFINED_TO\\)\\)\\|M\\(AX\\(IMIZE\\|_"
383     "\\(INTEGER\\|REAL\\)\\)\\|ETHODS?\\|INIMIZE\\|ODEL"
384     "\\)\\|NOT\\(\\|ES\\)\\|O\\([FR]\\|THERWISE\\|UTPUT\\)"
385     "\\|PRO\\(D\\|VIDE\\)\\|R\\(E\\(FINES\\|PLACE\\|QUIRE"
386     "\\|TURN\\)\\|UN\\)\\|S\\(ATISFIED\\|ELECT\\|IZE\\|TOP"
387     "\\|U\\(CH_THAT\\|M\\)\\|WITCH\\)\\|T\\(HEN\\|RUE\\)"
388     "\\|U\\(NI\\(ON\\|TS\\|VERSAL\\)\\|SE\\)\\|VALUE\\|W"
389     "\\(H\\(E\\(N\\|RE\\)\\|ILE\\)\\|I\\(LL_\\(BE\\(\\|"
390     "_THE_SAME\\)\\|NOT_BE_THE_SAME\\)\\|TH\\(\\|_VALUE"
391     "\\)\\)\\)\\)\\>")))
392     (method-regexp "\\<METHOD[ \t]+\\(\w+\\)")
393     (type-regexp
394     (concat "\\<\\(CONSTANT\\|DEFINITION\\|ATOM\\|MODEL\\)[ \t]+"
395     "\\(\w+\\)"))
396     )
397     (setq ascend-font-lock-keywords
398     (purecopy
399     (list keyword-regexp
400     (list method-regexp 1 'font-lock-function-name-face)
401     (list type-regexp 2 'font-lock-type-face)
402     )))))
403    
404     (put 'ascend-mode 'font-lock-defaults '(ascend-font-lock-keywords))
405    
406    
407     ;;; MENU
408     ;;; The only tricky thing about the menu is using either
409     ;;; zmacs-regions in XEmacs or mark-active in FSF Emacs
410     (if ascend-menu
411     ()
412     (setq ascend-menu
413     (list
414     '["Goto Block Start"
415     (ascend-beginning-of-block)
416     t]
417     '["Mark Current Block"
418     (ascend-mark-block 1)
419     t]
420     "---"
421     (vector
422     "Comment Out Region"
423     'comment-region
424     (if (boundp 'mark-active)
425     '(identity mark-active)
426     '(or (not zmacs-regions) (mark))))
427     (vector
428     "Indent Region"
429     'indent-region
430     (if (boundp 'mark-active)
431     '(identity mark-active)
432     '(or (not zmacs-regions) (mark))))
433     '["Indent Line"
434     ascend-indent-line
435     t]
436     "---"
437     '["Auto Newline On ;"
438     (setq ascend-auto-newline (not ascend-auto-newline))
439     :style toggle
440     :selected ascend-auto-newline]
441     '["Auto Indent On ;"
442     (setq ascend-semicolon-auto-indent
443     (not ascend-semicolon-auto-indent))
444     :active (not ascend-auto-newline)
445     :style toggle
446     :selected ascend-semicolon-auto-indent]
447     '["Auto Add Matching END"
448     (setq ascend-auto-add-end-statement
449     (not ascend-auto-add-end-statement))
450     :style toggle
451     :selected ascend-auto-add-end-statement]
452     '["Always Indent On TAB"
453     (setq ascend-tab-always-indent (not ascend-tab-always-indent))
454     :style toggle
455     :selected ascend-tab-always-indent]
456     '["Auto Indent On RETURN"
457     ascend-toggle-newline-linefeed
458     :style toggle
459     :selected (eq (key-binding "\C-m") 'electric-ascend-newline-indent)]
460     '["Auto Expand Abbreviations"
461     (setq abbrev-mode (not abbrev-mode))
462     :style toggle
463     :selected abbrev-mode]
464     '["Expand Abbrevs in Comments"
465     (setq ascend-expand-abbrevs-in-comments
466     (not ascend-expand-abbrevs-in-comments))
467     :active abbrev-mode
468     :style toggle
469     :selected ascend-expand-abbrevs-in-comments]
470     '"---"
471     '["Describe ASCEND mode"
472     describe-mode
473     t]
474     )))
475    
476    
477     ;;; ASCEND MODE
478     ;;;###autoload
479     (defun ascend-mode ()
480     "Major mode for editing ASCEND Code.
481     TAB indents for ASCEND code.
482     DELETE converts tabs to spaces as it moves back.
483     \\{ascend-mode-map}
484     Variables controlling indentation style:
485     ascend-auto-newline (default nil)
486     If nonnil, a newline is automatically inserted when
487     semicolon(;) is entered. Implies ascend-semicolon-auto-indent.
488     ascend-semicolon-auto-indent (default t)
489     If nonnil, entering a semicolon(;) will always indent
490     the current line.
491     ascend-tab-always-indent (default nil)
492     If nonnil, pressing TAB will always indent the current line;
493     otherwise, TAB will only indent if in the left margin.
494     ascend-block-indent-level (default 4)
495     Indentation of ASCEND statements in an block with
496     respect to the statement that starts the block.
497     ascend-continuation-indent-level (default 4)
498     Indentation of ASCEND statement continuations with respect
499     to statement start.
500    
501     Comments delimited by (* .. *). The statement separator is the semicolon.
502    
503     Turning on ASCEND-mode calls the value of the variable ascend-mode-hook
504     with no args, if that value is non-nil."
505     (interactive)
506     ;;
507     (kill-all-local-variables)
508     (use-local-map ascend-mode-map)
509     (setq major-mode 'ascend-mode)
510     (setq mode-name "ASCEND")
511     (setq local-abbrev-table ascend-abbrev-table)
512     (set-syntax-table ascend-mode-syntax-table)
513     ;;
514     (make-local-variable 'indent-line-function)
515     (setq indent-line-function 'ascend-indent-line)
516     ;;
517     (make-local-variable 'comment-start)
518     (setq comment-start "(*")
519     (make-local-variable 'comment-end)
520     (setq comment-end "*)")
521     (make-local-variable 'ascend-comment-start)
522     (setq ascend-comment-start (regexp-quote comment-start))
523     (make-local-variable 'ascend-comment-end)
524     (setq ascend-comment-end (regexp-quote comment-end))
525     (make-local-variable 'ascend-comment-start-end)
526     (setq ascend-comment-start-end (concat ascend-comment-start "\\|"
527     ascend-comment-end))
528     ;;
529     (make-local-variable 'ascend-notes-start)
530     (setq ascend-notes-start "{")
531     (make-local-variable 'ascend-notes-end)
532     (setq ascend-notes-end "}")
533     ;;
534     (make-local-variable 'ascend-block-start-regexp-list)
535     (setq ascend-block-start-regexp-list '("FOR"
536     "METHOD"
537     "\\(UNIVERSAL[ \t]+\\)?MODEL"
538     "\\(UNIVERSAL[ \t]+\\)?ATOM"
539     "IF"
540     "NOTES"
541     "SELECT"
542     "WHEN"
543     "SWITCH"
544     "WHILE"
545     "DEFINITION"
546     "UNITS"
547     "CONDITIONAL"
548     "DATA"
549     ))
550     (make-local-variable 'ascend-block-start-regexp)
551     (setq ascend-block-start-regexp
552     (concat "\\<\\("
553     (mapconcat 'identity ascend-block-start-regexp-list "\\|")
554     "\\)\\>"))
555     (make-local-variable 'ascend-block-end-regexp-list)
556     (setq ascend-block-end-regexp-list '("END"))
557     (make-local-variable 'ascend-block-end-regexp)
558     (setq ascend-block-end-regexp
559     (concat "\\<\\("
560     (mapconcat 'identity ascend-block-end-regexp-list "\\|")
561     "\\)\\>"))
562     (make-local-variable 'ascend-outdent-regexp-list)
563     (setq ascend-outdent-regexp-list '("\\<CASE\\>"
564     "\\<OTHERWISE\\>"
565     ")[ \t]*REFINES\\>"
566     "\\(\)[ \t]*\\)?WHERE[ \t\n]*\("
567     "\\<ELSE\\>"))
568     (make-local-variable 'ascend-outdent-regexp)
569     (setq ascend-outdent-regexp
570     (concat "\\("
571     (mapconcat 'identity ascend-outdent-regexp-list "\\|")
572     "\\)"))
573     (make-local-variable 'ascend-no-semi-regexp-list)
574     (setq ascend-no-semi-regexp-list '("METHODS"))
575     (make-local-variable 'ascend-no-semi-regexp)
576     (setq ascend-no-semi-regexp
577     (concat "\\<\\("
578     (mapconcat 'identity ascend-no-semi-regexp-list "\\|")
579     "\\)\\>"))
580     ;;
581     (ascend-create-menu)
582     (if (null (string-match "XEmacs" emacs-version))
583     (progn
584     ;; Do the font magic for FSF Emacs
585     (make-local-variable 'font-lock-keywords)
586     (setq font-lock-keywords
587     (append (list (list (car ascend-font-lock-keywords)
588     '(0 font-lock-keyword-face)))
589     (mapcar '(lambda (x) (list (car x) (cdr x)))
590     (cdr ascend-font-lock-keywords))))))
591     (run-hooks 'ascend-mode-hook))
592    
593    
594     ;;;
595     ;;; Electric functions ------------------------------------------------------
596     ;;;
597    
598     (defun electric-ascend-newline (count)
599     "Insert COUNT newlines."
600     (interactive "P")
601     (delete-horizontal-space)
602     (ascend-indent-line)
603     (if ascend-auto-add-end-statement
604     (ascend-add-matching-end-block))
605     (newline (prefix-numeric-value count)))
606    
607    
608     (defun electric-ascend-newline-indent (count)
609     "Insert COUNT newlines then indent final line."
610     (interactive "P")
611     (electric-ascend-newline count)
612     (indent-to (ascend-calculate-indentation)))
613    
614    
615     (defun electric-ascend-tab (count)
616     "Called when TAB is pressed. If COUNT is specified,
617     insert COUNT tabs; if ascend-tab-always-indent is t, indent line;
618     otherwise, only indent if before first character on line."
619     (interactive "P")
620     (cond (count
621     (self-insert-command (prefix-numeric-value count)))
622     (ascend-tab-always-indent
623     (ascend-indent-line))
624     ((ascend-point-in-left-margin-p)
625     (ascend-indent-line))
626     ((ascend-point-in-string-p)
627     ())
628     (t
629     (self-insert-command 1))))
630    
631    
632     (defun electric-ascend-semicolon (count)
633     "Called when semicolon(;) is pressed. If COUNT is
634     specified, insert COUNT semicolons; otherwise insert a semicolon and
635     correct line's indentation. If ascend-auto-newline is t, insert newline."
636     (interactive "P")
637     (cond (count
638     (self-insert-command (prefix-numeric-value count)))
639     ((ascend-point-in-comment-p)
640     (self-insert-command 1))
641     ((ascend-point-in-string-p)
642     ())
643     (ascend-auto-newline
644     (self-insert-command 1)
645     (ascend-indent-line)
646     (if ascend-auto-add-end-statement
647     (ascend-add-matching-end-block))
648     (newline-and-indent))
649     (ascend-semicolon-auto-indent
650     (self-insert-command 1)
651     (ascend-indent-line))
652     (t
653     (self-insert-command 1))))
654    
655    
656     ;;;
657     ;;; Interactive functions ---------------------------------------------------
658     ;;;
659    
660    
661     (defun ascend-toggle-newline-linefeed (arg)
662     "Toggle the meanings of newline (C-m) and linefeed (C-j).
663     By default in ASCEND-mode, NEWLINE runs 'electric-ascend-newline-indent
664     ---which inserts a newline and indents---and LINEFEED calls
665     'electric-ascend-newline---which inserts a newline but does not indent).
666     Calling this function without an argument toggles the meanings; if ARG is
667     specified and is positive, newline is set to 'electric-ascend-newline;
668     otherwise newline is set to 'electric-ascend-newline-indent."
669     (interactive "P")
670     (if (or (and (not arg)
671     (eq (key-binding "\C-m") 'electric-ascend-newline-indent))
672     (< 0 (prefix-numeric-value arg)))
673     (progn
674     (define-key ascend-mode-map "\C-m" 'electric-ascend-newline)
675     (define-key ascend-mode-map "\C-j" 'electric-ascend-newline-indent))
676     (define-key ascend-mode-map "\C-m" 'electric-ascend-newline-indent)
677     (define-key ascend-mode-map "\C-j" 'electric-ascend-newline)))
678    
679    
680     ;;;
681     ;;; Indenting functions (interactive) ---------------------------------------
682     ;;;
683    
684    
685     (defun ascend-calculate-indentation ()
686     "Calculate the indentation of the current ASCEND line without
687     modifying the buffer."
688     (let ((case-fold-search nil)
689     tmp
690     ;; tmp is the point where the current comment starts--when we
691     ;; are in a comment; if we are not in a comment, it is nil
692     )
693     (save-excursion
694     ;; The next two lines put us on the first nonwhitespace character on
695     ;; the line---if we've been called from indent-line, then this
696     ;; should have already been done.
697     (beginning-of-line)
698     (skip-chars-forward " \t")
699     (cond (;; handle comments
700     (setq tmp (ascend-point-in-comment-p))
701     (let (;; count-stars is the number of asterisks that start the
702     ;; current line--ignoring any leading whitespace
703     (count-stars (if (looking-at "\\*+")
704     (apply '- (match-data))
705     0)))
706     ;; The next line searches for the previous nonblank line
707     ;; within the current comment; if there isn't one, it
708     ;; leaves point on the comment start character
709     (re-search-backward "^[ \t]*\\S-" tmp 1)
710     (if (looking-at ascend-comment-start)
711     (progn
712     ;; There was no nonblank line--we are current looking
713     ;; at "(" followed be one or more "*"s. Set the
714     ;; indentation to the column after the last asterisk,
715     ;; except any asterisks that start the line we are
716     ;; indenting should fall under asterisks in the
717     ;; previous line. For example
718     ;; (******
719     ;; ** foo
720     (forward-char 1) ;; skip the "("
721     (skip-chars-forward "\\*") ;; skip the "*"s
722     (max 0 (+ count-stars (current-column))))
723     (progn
724     ;; We found a nonblank line. Set the indentation to
725     ;; the column containing the first nonblank character.
726     ;; Ignore asterisks in the previous and current lines.
727     (skip-syntax-forward " ")
728     (current-column)))))
729     (;; handle notes
730     (ascend-point-in-note-p)
731     (current-column))
732     (;; handle the end of a block
733     (looking-at ascend-block-end-regexp)
734     (if (setq tmp (ascend-get-matching-block-start))
735     (goto-char tmp))
736     (current-column))
737     (;; handle outdented keywords like ELSE or CASE
738     (remove-if-not 'looking-at ascend-outdent-regexp-list)
739     (if (setq tmp (ascend-pos-beginning-of-block 1))
740     (goto-char tmp))
741     (current-column))
742     (;; Lines that begin with a close-paren should indent to the
743     ;; column of the first nonblank character on the line
744     ;; containing the matching open-paren.
745     (looking-at ")")
746     (forward-char 1)
747     (backward-sexp)
748     (beginning-of-line)
749     (skip-syntax-forward " ")
750     (current-column))
751     (;; This statement puts us on the previous nonblank line. If
752     ;; this branch fires, then no previous nonblank line exists,
753     ;; and we should set the indentation to 0.
754     (null (re-search-backward "^[ \t]*\\S-" nil t))
755     0)
756     (;; Going backward may have put us in a comment; if so, go to
757     ;; the beginning of the comment and start the process all
758     ;; over again.
759     (setq tmp (ascend-point-in-comment-p))
760     (goto-char tmp)
761     (ascend-calculate-indentation))
762     (;; This statement puts us on the first nonblank character on
763     ;; the previous nonblank line. We then check to see if it is
764     ;; a block-start statement; if so, we need to indent by the
765     ;; block-indent-level.
766     (and (progn
767     (beginning-of-line)
768     (skip-chars-forward " \t"))
769     (looking-at ascend-block-start-regexp))
770     (+ (current-column) ascend-block-indent-level))
771     (;; check if it is an outdented statement
772     (looking-at ascend-outdent-regexp)
773     (+ (current-column) ascend-block-indent-level))
774     (;; just return the current column
775     t
776     (current-column))
777     ;; The following will not get invoked because of the
778     ;; t on the previous condition. We need to do something
779     ;; here to get continuation lines to work.
780     ;;;;;;;;;;;;;;;;;;;;;;;;;;
781     ((looking-at ascend-comment-start)
782     ;; Code should line up with comments
783     (looking-at ascend-comment-start)
784     (current-column))
785     (;; This line does not require a semicolon, so it should be
786     ;; considered complete, and the next line should NOT be
787     ;; considered a continuation line.
788     (remove-if-not 'looking-at ascend-no-semi-regexp-list)
789     (current-column))
790     ((save-excursion
791     (end-of-line)
792     (if (setq tmp (ascend-point-in-comment-p))
793     (goto-char tmp))
794     (skip-syntax-backward " ")
795     (forward-char -1)
796     (looking-at ";"))
797     ;; This line ends in a semicolon, so the next line should NOT
798     ;; be considered a continuation line.
799     (current-column))
800     (t
801     ;; Consider the line to be a continuation line
802     (+ (current-column) ascend-continuation-indent-level)))
803     )))
804    
805    
806     (defun ascend-indent-line ()
807     "Indent the current line relative to the current block."
808     (interactive)
809     (let ((m (point-marker)))
810     (beginning-of-line)
811     (if (ascend-point-in-note-p)
812     nil
813     (delete-horizontal-space)
814     (indent-to (ascend-calculate-indentation)))
815     (if (> m (point))
816     (goto-char m))))
817    
818    
819     ;;;
820     ;;; Marking functions (interactive) -----------------------------------------
821     ;;;
822    
823    
824     (defun ascend-mark-block (count)
825     "If point is inside a block, mark the current block by putting mark
826     at the beginning and point at the end. If point is outside a block,
827     mark the first complete block we find \(designated by the first END
828     statement\). With argument COUNT, mark COUNT blocks outward or
829     forward."
830     (interactive "p")
831     (if (re-search-forward ascend-block-end-regexp nil t count)
832     ;; if this fails, we haven't moved. if it succeeds, we are
833     ;; sitting just after END. Go backward one word to the start of
834     ;; END, then get the position where of the matching block start.
835     ;; Go to the end of the line, push the mark to the beginning of
836     ;; the block, and then activate the region.
837     (let (beg-defun)
838     (skip-syntax-backward "w_")
839     (setq beg-defun (ascend-get-matching-block-start))
840     (end-of-line)
841     (push-mark beg-defun nil t))))
842    
843    
844     ;;;
845     ;;; Movement functions (interactive) ---------------------------------------
846     ;;;
847    
848    
849     (defun ascend-backward-block (count)
850     "Move backward to the next statement that begins an ASCEND block.
851     With argument COUNT, move backward COUNT begin statements. Treats
852     comments and NOTES as whitespace."
853     (interactive "p")
854     (goto-char (or (ascend-pos-block-backward count) (point-min))))
855    
856    
857     (defun ascend-forward-block (count)
858     "Move forward to the next statement that ends an ASCEND block. With
859     argument COUNT, move forward COUNT end statements. Treats comments
860     and NOTES as whitespace."
861     (interactive "p")
862     (goto-char (or (ascend-pos-block-forward count) (point-min)))
863     (end-of-line))
864    
865    
866     (defun ascend-beginning-of-block (count)
867     "Go to the beginning of the current block. With argument COUNT,
868     move outward COUNT blocks. Treats comments and NOTES as whitespace.
869    
870     This function differs from ascend-backward-block in that matching
871     begin-block/end-block pairs are skipped, so that point moves to the
872     beginning of the block that contains point, not to the beginning of
873     the first begin-block statement we find."
874     (interactive "p")
875     (goto-char (or (ascend-pos-beginning-of-block count) (point-min))))
876    
877    
878     (defun ascend-end-of-block (count)
879     "Go to the end of the current block. With argument COUNT, move
880     outward COUNT blocks. Treats comments and NOTES as whitespace.
881    
882     This function differs from ascend-forward-block in that matching
883     begin-block/end-block pairs are skipped, so that point moves to the
884     end of the block that contains point, not to the end of the first
885     end-block statement we find."
886     (interactive "p")
887     (goto-char (or (ascend-pos-end-of-block count) (point-max)))
888     (end-of-line))
889    
890     ;;;
891     ;;; Is point here? ----------------------------------------------------------
892     ;;;
893    
894    
895     (defun ascend-point-in-comment-p ()
896     "If point is in an ASCEND comment, return the character
897     position where the comment begins; otherwise return nil."
898     ;; Search backward for the first ascend-comment-start or
899     ;; ascend-comment-end expression we see; if we find a
900     ;; ascend-comment-start, we are in a comment and return point;
901     ;; otherwise, we are not in a comment and return nil. NOTE: Does
902     ;; not handle nested comments; does not handle "(*)" correctly; does
903     ;; not process ascend-comment-start/ascend-comment-end characters in
904     ;; symbols and notes correctly.
905     (save-match-data
906     (save-excursion
907     (and (re-search-backward ascend-comment-start-end nil t)
908     (looking-at ascend-comment-start)
909     (point)))))
910    
911    
912     ;;;(defun ascend-point-in-nested-comment-p ()
913     ;;; "Return t if point is in a nested ASCEND comment."
914     ;;; ;; Set c to zero; search backward for ascend-comment-start and
915     ;;; ;; ascend-comment-end expressions; increment/decrement c for each
916     ;;; ;; ascend-comment-start/-end; if c is > 0 when we reach the
917     ;;; ;; beginning of the buffer, we are in a comment. NOTE: Handles
918     ;;; ;; nested comments, but does not handle "(*)" correctly; does not
919     ;;; ;; process ascend-comment-start/ascend-comment-end characters in
920     ;;; ;; symbols and notes correctly.
921     ;;; (let ((c 0))
922     ;;; (save-excursion
923     ;;; (while (re-search-backward ascend-comment-start-end
924     ;;; nil t)
925     ;;; (setq c (if (looking-at ascend-comment-start) (1+ c) (1- c)))))
926     ;;; (> c 0)))
927    
928    
929     (defun ascend-point-in-note-p ()
930     "Return the position of the starting character if point
931     is in an ASCEND notes block."
932     (save-match-data
933     (save-excursion
934     (and (re-search-backward (concat ascend-notes-start "\\|"
935     ascend-notes-end)
936     nil t)
937     (looking-at ascend-notes-start)
938     (point)))))
939    
940    
941     (defun ascend-point-in-string-p ()
942     "Return the position of the starting character if point
943     is within an ASCEND string.
944     Assumes strings never contain newlines."
945     (save-match-data
946     (save-excursion
947     (let (;; parse from the beginning-of-line to point
948     (p (point))
949     ;; the character that begins the string
950     c)
951     (beginning-of-line)
952     ;; since {} are treated as string delimiters in XEmacs, we
953     ;; have to watch for them in the call to parse-partial-sexp.
954     ;; If we get \} as a close string character, pretend we are
955     ;; not in a string
956     (if (and (setq c (nth 3 (parse-partial-sexp (point) p)))
957     (null (eq c ?\})))
958     (progn
959     (search-backward (char-to-string c))
960     (point)))))))
961    
962    
963     (defun ascend-point-in-left-margin-p ()
964     "Return t if point is in left margin; the left margin is
965     the whitespace between the left edge of the page and the start of text
966     on the line."
967     (save-excursion
968     (skip-chars-backward " \t")
969     (bolp)))
970    
971    
972     ;;;
973     ;;; Where is some text? -----------------------------------------------------
974     ;;;
975    
976    
977     (defun ascend-pos-block-backward (count)
978     "Return the position of the next unprotected
979     ascend-block-start-statement. Return nil if we do not find a block
980     start statement."
981     (save-excursion
982     (let (;; match case inside of this function
983     (case-fold-search nil)
984     ;; tmp holds the beginning of the current comment, string,
985     ;; or note
986     tmp)
987     (while (and (> count 0)
988     (re-search-backward ascend-block-start-regexp nil t))
989     (cond (;; ignore strings, comments, and notes
990     (setq tmp (or (ascend-point-in-string-p)
991     (ascend-point-in-comment-p)
992     (ascend-point-in-note-p)))
993     (goto-char tmp))
994     (;; ignore block-starts that following block-ends: go
995     ;; backward one token to make sure we are not sitting
996     ;; on the "FOR" of an "END FOR" statement
997     (progn (skip-syntax-backward " ")
998     (skip-syntax-backward "w_")
999     (looking-at ascend-block-end-regexp)))
1000     (t
1001     (setq count (1- count)))))
1002     (match-beginning 0))))
1003    
1004    
1005     (defun ascend-pos-block-forward (count)
1006     "Return the position of the next unprotected
1007     ascend-block-end-statement. Return nil if we do not find a block end
1008     statement."
1009     (save-excursion
1010     (let (;; match case inside of this function
1011     (case-fold-search nil))
1012     (while (and (> count 0)
1013     (re-search-forward ascend-block-end-regexp nil t))
1014     (if (not (or (ascend-point-in-string-p)
1015     (ascend-point-in-comment-p)
1016     (ascend-point-in-note-p)))
1017     (setq count (1- count))))
1018     (match-beginning 0))))
1019    
1020    
1021     (defun ascend-pos-beginning-of-block (count)
1022     "Return the position of the start of the block that currently
1023     contains point. Return nil if we do not find a block-start statement.
1024     Comments and notes are treated as whitespace.
1025    
1026     This function searches backward for ascend-block-start-regexp. This
1027     function differs from ascend-pos-block-backward in that matching
1028     block-end/block-start statements are ignored."
1029     (let (;; match case inside of this function
1030     (case-fold-search nil)
1031     ;; level is used to keep track of the begin-blocks and end-blocks;
1032     ;; it is initially count, indicating we are inside count
1033     ;; levels of nested blocks
1034     (level count)
1035     ;; tmp is used for random values, such as the start of a comment,
1036     ;; the current value of point, etc.
1037     tmp
1038     ;; the regexp to match the begins and ends of blocks
1039     (regex (concat "\\(" ascend-block-start-regexp "\\|"
1040     ascend-block-end-regexp "\\)")))
1041     (save-excursion
1042     ;; ;; move to the beginning of the line and see if we are looking
1043     ;; ;; at a block-start, if so adjust the level. we have to do
1044     ;; ;; this, otherwise sitting just after the END keyword will
1045     ;; ;; behave as if we're not in that block.
1046     ;; (skip-syntax-backward " ")
1047     ;; (beginning-of-line)
1048     ;; (skip-chars-forward " \t")
1049     ;; (if (and (looking-at ascend-block-start-regexp)
1050     ;; (not (or (ascend-point-in-string-p)
1051     ;; (ascend-point-in-comment-p)
1052     ;; (ascend-point-in-note-p))))
1053     ;; (setq level (1- level)))
1054     (while (and (> level 0)
1055     (re-search-backward regex nil t))
1056     (cond (;; get out of the string, comment, or not
1057     (setq tmp (or (ascend-point-in-string-p)
1058     (ascend-point-in-comment-p)
1059     (ascend-point-in-note-p)))
1060     (goto-char tmp))
1061     (;; we're at block-end position; increase the level
1062     (looking-at ascend-block-end-regexp)
1063     (setq level (1+ level)))
1064     ;; at this point we know we are on a block-start. go
1065     ;; backward one token to make sure we are not sitting on the
1066     ;; "FOR" of an "END FOR" statement
1067     ((progn (setq tmp (- 0 (skip-syntax-backward " ")
1068     (skip-syntax-backward "w_")))
1069     (looking-at ascend-block-end-regexp))
1070     (setq level (1+ level)))
1071     (t
1072     (forward-char tmp)
1073     (setq level (1- level)))))
1074     (if (zerop level)
1075     (point)
1076     nil))))
1077    
1078    
1079     (defun ascend-pos-end-of-block (count)
1080     "Return the position of the end of the block that currently contains
1081     point. Return nil if we do not find a block-end statement. Comments
1082     and notes are treated as whitespace.
1083    
1084     This function searches forward for ascend-block-end-regexp. This
1085     function differs from ascend-pos-block-forward in that matching
1086     block-end/block-start statements are ignored."
1087     (let (;; match case inside of this function
1088     (case-fold-search nil)
1089     ;; level is used to keep track of the begin-blocks and end-blocks;
1090     ;; it is initially count, indicating we are inside coun
1091     ;; levels of nested blocks
1092     (level count)
1093     ;; tmp is used for random values, such as the start of a comment,
1094     ;; the current value of point, etc.
1095     tmp
1096     ;; the regexp to match the begins and ends of blocks
1097     (regex (concat "\\(" ascend-block-start-regexp "\\|"
1098     ascend-block-end-regexp "\\)")))
1099     (save-excursion
1100     ;; ;; move to the first non-whitespace character on the line and
1101     ;; ;; see if we are looking at a block-end, if so adjust the level.
1102     ;; ;; we have to do this, otherwise sitting just before a
1103     ;; ;; block-start keyword will behave as if we're not in that
1104     ;; ;; block.
1105     ;; (skip-syntax-forward " ")
1106     ;; (if (and (looking-at ascend-block-end-regexp)
1107     ;; (not (or (ascend-point-in-string-p)
1108     ;; (ascend-point-in-comment-p)
1109     ;; (ascend-point-in-note-p))))
1110     ;; (setq level (1- level)))
1111     (while (and (> level 0)
1112     (re-search-forward regex nil t))
1113     ;; save point: since we move backward below, we need to return
1114     ;; here before our next time through the loop so we don't
1115     ;; match the same regexp again
1116     (setq tmp (point))
1117     ;; we're at the end of the regexp, move to the front
1118     (goto-char (match-beginning 0))
1119     (cond (;; if we are in a string, comment, or note, we need to
1120     ;; keep searching. unfortunately, there is no quick
1121     ;; way to jump out the end of a string, comment, or
1122     ;; note like there is for the beginning. Move to tmp
1123     ;; before we continue.
1124     (or (ascend-point-in-string-p)
1125     (ascend-point-in-comment-p)
1126     (ascend-point-in-note-p))
1127     (goto-char tmp))
1128     (;; we're at block-end position; decrease the level and
1129     ;; move to the end of the line, otherwise, if sitting
1130     ;; on ``END FOR;'' we will match the FOR as a
1131     ;; block-start
1132     (looking-at ascend-block-end-regexp)
1133     (setq level (1- level))
1134     (end-of-line))
1135     (;; at this point we know we are on a block-start. go
1136     ;; backward one token to make sure we are not sitting
1137     ;; on the "FOR" of an "END FOR" statement. If we are
1138     ;; on END FOR, decrease the level and move to the end
1139     ;; of the line
1140     (progn (skip-syntax-backward " ")
1141     (skip-syntax-backward "w_")
1142     (looking-at ascend-block-end-regexp))
1143     (setq level (1- level))
1144     (end-of-line))
1145     (;; we know we are on a block start that is really a
1146     ;; block start. increase the level and move to the end
1147     ;; of our orignial match
1148     t
1149     (setq level (1+ level))
1150     (goto-char tmp))))
1151     (if (zerop level)
1152     (point)
1153     nil))))
1154    
1155    
1156     (defun ascend-get-matching-block-start ()
1157     "Return the position of the start of the block which the
1158     current token ends. Signals an error if the matching block
1159     start is not found.
1160    
1161     This function expects to point to be sitting on an entry in the
1162     ascend-block-end-regexp-list. To find the beginning of the current
1163     block from inside the block, call ascend-pos-beginning-of-block."
1164     (let (;; match case inside of this function
1165     (case-fold-search nil)
1166     ;; end-line is the line number where we are; it is used
1167     ;; when signaling an error.
1168     (end-line (1+ (count-lines (point-min) (point))))
1169     ;; level is used to keep track of the begin-blocks and end-blocks;
1170     ;; it is initially 1, indicating we are inside a block
1171     (level 1)
1172     ;; blocktype holds the token after the END
1173     blocktype
1174     ;; tmp is used for random values, such as the start of a comment,
1175     ;; the current value of point, etc.
1176     tmp)
1177     (save-excursion
1178     ;; Signal an error if we are not where we expect to be
1179     (if (null (looking-at ascend-block-end-regexp))
1180     (error "%s" "Not on an block-end-line"))
1181     ;; Skip over the block-end-regexp and any whitespace
1182     (goto-char (match-end 0))
1183     (skip-syntax-forward " ")
1184     ;; The next token is the type of the block
1185     (setq blocktype (buffer-substring (point) (progn
1186     (skip-syntax-forward "w_")
1187     (point))))
1188     ;; Signal an error if no token follows END
1189     (if (string= blocktype "")
1190     (error "%s" "Missing token after END"))
1191     ;; See if we recognize the token after "END"
1192     (if (string-match (concat "\\`" ascend-block-start-regexp "\\'")
1193     blocktype)
1194     (progn
1195     ;; The word after "END"---blocktype---is a block-start
1196     ;; keyword, so search backward for blocktype, adding a level
1197     ;; if it is preceeded by "END" and subtracting a level if not.
1198     ;; Return when the level is zero.
1199     (beginning-of-line)
1200     (while (and (> level 0)
1201     (re-search-backward (concat "\\b" blocktype "\\b")
1202     nil t))
1203     (if (setq tmp (or (ascend-point-in-string-p)
1204     (ascend-point-in-comment-p)
1205     (ascend-point-in-note-p)))
1206     (goto-char tmp)
1207     ;(forward-char 1)
1208     (setq tmp (point))
1209     (skip-syntax-backward " ")
1210     (skip-syntax-backward "w_")
1211     (if (looking-at ascend-block-end-regexp)
1212     (setq level (1+ level))
1213     (setq level (1- level)))))
1214     (if (zerop level)
1215     tmp
1216     (error "%s%s%s%d" "Cannot find beginning of " blocktype
1217     " block that ends on line " end-line)))
1218     (progn
1219     ;; We do not recognize the word after "END"---blocktype---as a
1220     ;; block-start, so look for a block-start followed by
1221     ;; blocktype.
1222     (while (and (re-search-backward (concat ascend-block-start-regexp
1223     "\\s-+" blocktype
1224     "\\>")
1225     nil t)
1226     (setq tmp (or (ascend-point-in-string-p)
1227     (ascend-point-in-comment-p)
1228     (ascend-point-in-note-p))))
1229     (goto-char tmp))
1230     (if (looking-at (concat ascend-block-start-regexp "\\s-+"
1231     blocktype "\\>"))
1232     (point)
1233     (error "%s%s%s%d" "Cannot find beginning of block " blocktype
1234     " that ends on line " end-line)))))))
1235    
1236    
1237     ;;;
1238     ;;; Misc functions ----------------------------------------------------------
1239     ;;;
1240    
1241    
1242     (defun ascend-undo-abbrev-in-comment ()
1243     "If point is in an ascend comment,
1244     undo the previous abbrev expansion."
1245     (if (and (not ascend-expand-abbrevs-in-comments)
1246     (or (ascend-point-in-string-p)
1247     (ascend-point-in-comment-p)
1248     (ascend-point-in-note-p)))
1249     (unexpand-abbrev)))
1250    
1251    
1252     (defun ascend-version ()
1253     "Print the version number of ASCEND mode in the minibuffer"
1254     (interactive)
1255     (message "ASCEND mode version %s Ident: $Id$" ascend-mode-version))
1256    
1257    
1258     (defun ascend-add-matching-end-block ()
1259     "Add the matching end"
1260     (let ((case-fold-search nil) block indentation)
1261     (save-excursion
1262     (beginning-of-line)
1263     (setq indentation (skip-chars-forward " \t"))
1264     (if (or (not (looking-at ascend-block-start-regexp))
1265     (looking-at "\\<ELSE\\>"))
1266     ;; nothing to do
1267     ()
1268     (if (looking-at "\\bUNIVERSAL\\b")
1269     (progn
1270     (skip-syntax-forward "w_")
1271     (skip-syntax-forward " ")))
1272     (if (looking-at "\\<\\(METHOD\\|ATOM\\|MODEL\\|DEFINITON\\)\\>")
1273     (progn
1274     (skip-syntax-forward "w_")
1275     (skip-syntax-forward " ")))
1276     (setq block (buffer-substring (point) (progn (skip-syntax-forward "w_")
1277     (point))))
1278     (end-of-line)
1279     (insert "\nEND " block ";")
1280     (beginning-of-line)
1281     (indent-to indentation)))))
1282    
1283    
1284     ;;;
1285     ;;; Menus -------------------------------------------------------------------
1286     ;;;
1287    
1288    
1289     (defun ascend-create-menu ()
1290     "Modify this buffer's menubar to include the ASCEND menu.
1291     Won't create the menubar if one doesn't already exist."
1292     (interactive)
1293     (cond ((not ascend-menu)
1294     ;; do nothing
1295     )
1296     ((and (string-match "XEmacs" emacs-version) current-menubar)
1297     (set-buffer-menubar current-menubar)
1298     (add-submenu nil (append '("ASCEND") ascend-menu)))
1299     ((and (string-match "Lucid" emacs-version) current-menubar)
1300     (set-buffer-menubar current-menubar)
1301     (add-menu nil "ASCEND" (copy-tree ascend-menu)))
1302     ((string-match "^[.0-9]+$" emacs-version)
1303     (load "easymenu")
1304     (easy-menu-define ascend ascend-mode-map "Ascend mode menu"
1305     (cons "Ascend" ascend-menu)))))
1306    
1307    
1308     ;;;
1309     ;;; Done --------------------------------------------------------------------
1310     ;;;
1311    
1312     (provide 'ascend-mode)
1313    
1314     ;; ascend-mode.el ends here

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22