cgit.sxemacs.org Git - packages/blob - xemacs-packages/prog-modes/modula2.el

   1 ;;; modula2.el --- Modula-2 editing support package
   2
   3 ;; Author: Michael Schmidt <michael@pbinfo.UUCP>
   4 ;;      Tom Perrine <Perrin@LOGICON.ARPA>
   5 ;; Maintainer: FSF
   6 ;; Keywords: languages
   7
   8 ;; This file is part of XEmacs.
   9
  10 ;; XEmacs is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; XEmacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23 ;; 02111-1307, USA.
  24
  25 ;;; Synched up with: GNU Emacs 21.2.
  26
  27 ;; The authors distributed this without a copyright notice
  28 ;; back in 1988, so it is in the public domain.  The original included
  29 ;; the following credit:
  30
  31 ;; Author Mick Jordan
  32 ;; amended Peter Robinson
  33
  34 ;;; Commentary:
  35
  36 ;; A major mode for editing Modula-2 code.  It provides convenient abbrevs
  37 ;; for Modula-2 keywords, knows about the standard layout rules, and supports
  38 ;; a native compile command.
  39
  40 ;;; Code:
  41
  42 (defgroup modula2 nil
  43   "Major mode for editing Modula-2 code."
  44   :prefix "m2-"
  45   :group 'languages)
  46
  47 ;;; Added by Tom Perrine (TEP)
  48 (defvar m2-mode-syntax-table nil
  49   "Syntax table in use in Modula-2 buffers.")
  50
  51 (defcustom m2-compile-command "m2c"
  52   "Command to compile Modula-2 programs."
  53   :type 'string
  54   :group 'modula2)
  55
  56 (defcustom m2-link-command "m2l"
  57   "Command to link Modula-2 programs."
  58   :type 'string
  59   :group 'modula2)
  60
  61 (defcustom m2-link-name nil
  62   "Name of the Modula-2 executable."
  63   :type '(choice (const nil) string)
  64   :group 'modula2)
  65
  66 (defcustom m2-end-comment-column 75
  67   "*Column for aligning the end of a comment, in Modula-2."
  68   :type 'integer
  69   :group 'modula2)
  70
  71 (if m2-mode-syntax-table
  72     ()
  73   (let ((table (make-syntax-table)))
  74     (modify-syntax-entry ?\\ "\\" table)
  75     (modify-syntax-entry ?\( ". 1" table)
  76     (modify-syntax-entry ?\) ". 4" table)
  77     (modify-syntax-entry ?* ". 23" table)
  78     (modify-syntax-entry ?+ "." table)
  79     (modify-syntax-entry ?- "." table)
  80     (modify-syntax-entry ?= "." table)
  81     (modify-syntax-entry ?% "." table)
  82     (modify-syntax-entry ?< "." table)
  83     (modify-syntax-entry ?> "." table)
  84     (modify-syntax-entry ?\' "\"" table)
  85     (setq m2-mode-syntax-table table)))
  86
  87 ;;; Added by TEP
  88 (defvar m2-mode-map nil
  89   "Keymap used in Modula-2 mode.")
  90
  91 (if m2-mode-map ()
  92   (let ((map (make-sparse-keymap)))
  93     (define-key map "\^i" 'm2-tab)
  94     (define-key map "\C-cb" 'm2-begin)
  95     (define-key map "\C-cc" 'm2-case)
  96     (define-key map "\C-cd" 'm2-definition)
  97     (define-key map "\C-ce" 'm2-else)
  98     (define-key map "\C-cf" 'm2-for)
  99     (define-key map "\C-ch" 'm2-header)
 100     (define-key map "\C-ci" 'm2-if)
 101     (define-key map "\C-cm" 'm2-module)
 102     (define-key map "\C-cl" 'm2-loop)
 103     (define-key map "\C-co" 'm2-or)
 104     (define-key map "\C-cp" 'm2-procedure)
 105     (define-key map "\C-c\C-w" 'm2-with)
 106     (define-key map "\C-cr" 'm2-record)
 107     (define-key map "\C-cs" 'm2-stdio)
 108     (define-key map "\C-ct" 'm2-type)
 109     (define-key map "\C-cu" 'm2-until)
 110     (define-key map "\C-cv" 'm2-var)
 111     (define-key map "\C-cw" 'm2-while)
 112     (define-key map "\C-cx" 'm2-export)
 113     (define-key map "\C-cy" 'm2-import)
 114     (define-key map "\C-c{" 'm2-begin-comment)
 115     (define-key map "\C-c}" 'm2-end-comment)
 116     (define-key map "\C-j"  'm2-newline)
 117     (define-key map "\C-c\C-z" 'suspend-emacs)
 118     (define-key map "\C-c\C-v" 'm2-visit)
 119     (define-key map "\C-c\C-t" 'm2-toggle)
 120     (define-key map "\C-c\C-l" 'm2-link)
 121     (define-key map "\C-c\C-c" 'm2-compile)
 122     (setq m2-mode-map map)))
 123
 124 (defcustom m2-indent 5
 125   "*This variable gives the indentation in Modula-2-Mode."
 126   :type 'integer
 127   :group 'modula2)
 128
 129 ;;;###autoload
 130 (defun modula-2-mode ()
 131   "This is a mode intended to support program development in Modula-2.
 132 All control constructs of Modula-2 can be reached by typing C-c
 133 followed by the first character of the construct.
 134 \\<m2-mode-map>
 135   \\[m2-begin] begin         \\[m2-case] case
 136   \\[m2-definition] definition    \\[m2-else] else
 137   \\[m2-for] for           \\[m2-header] header
 138   \\[m2-if] if            \\[m2-module] module
 139   \\[m2-loop] loop          \\[m2-or] or
 140   \\[m2-procedure] procedure     Control-c Control-w with
 141   \\[m2-record] record        \\[m2-stdio] stdio
 142   \\[m2-type] type          \\[m2-until] until
 143   \\[m2-var] var           \\[m2-while] while
 144   \\[m2-export] export        \\[m2-import] import
 145   \\[m2-begin-comment] begin-comment \\[m2-end-comment] end-comment
 146   \\[suspend-emacs] suspend Emacs     \\[m2-toggle] toggle
 147   \\[m2-compile] compile           \\[m2-next-error] next-error
 148   \\[m2-link] link
 149
 150    `m2-indent' controls the number of spaces for each indentation.
 151    `m2-compile-command' holds the command to compile a Modula-2 program.
 152    `m2-link-command' holds the command to link a Modula-2 program."
 153   (interactive)
 154   (kill-all-local-variables)
 155   (use-local-map m2-mode-map)
 156   (setq major-mode 'modula-2-mode)
 157   (setq mode-name "Modula-2")
 158   (make-local-variable 'comment-column)
 159   (setq comment-column 41)
 160   (make-local-variable 'm2-end-comment-column)
 161   (set-syntax-table m2-mode-syntax-table)
 162   (make-local-variable 'paragraph-start)
 163   (setq paragraph-start (concat "$\\|" page-delimiter))
 164   (make-local-variable 'paragraph-separate)
 165   (setq paragraph-separate paragraph-start)
 166   (make-local-variable 'paragraph-ignore-fill-prefix)
 167   (setq paragraph-ignore-fill-prefix t)
 168 ;  (make-local-variable 'indent-line-function)
 169 ;  (setq indent-line-function 'c-indent-line)
 170   (make-local-variable 'require-final-newline)
 171   (setq require-final-newline t)
 172   (make-local-variable 'comment-start)
 173   (setq comment-start "(* ")
 174   (make-local-variable 'comment-end)
 175   (setq comment-end " *)")
 176   (make-local-variable 'comment-column)
 177   (setq comment-column 41)
 178   (make-local-variable 'comment-start-skip)
 179   (setq comment-start-skip "/\\*+ *")
 180   (make-local-variable 'comment-indent-function)
 181   (setq comment-indent-function 'c-comment-indent)
 182   (make-local-variable 'parse-sexp-ignore-comments)
 183   (setq parse-sexp-ignore-comments t)
 184   (make-local-variable 'font-lock-defaults)
 185   (setq font-lock-defaults
 186         '((m3-font-lock-keywords
 187            m3-font-lock-keywords-1 m3-font-lock-keywords-2)
 188           nil nil ((?_ . "w") (?. . "w") (?< . ". 1") (?> . ". 4")) nil
 189           ;; Obsoleted by Emacs 19.35 parse-partial-sexp's COMMENTSTOP.
 190           ;(font-lock-comment-start-regexp . "(\\*")
 191           ))
 192   (run-hooks 'm2-mode-hook))
 193 \f
 194 ;; Regexps written with help from Ron Forrester <ron@orcad.com>
 195 ;; and Spencer Allain <sallain@teknowledge.com>.
 196 (defconst m3-font-lock-keywords-1
 197   '(
 198     ;;
 199     ;; Module definitions.
 200     ("\\<\\(INTERFACE\\|MODULE\\|PROCEDURE\\)\\>[ \t]*\\(\\sw+\\)?"
 201      (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
 202     ;;
 203     ;; Import directives.
 204     ("\\<\\(EXPORTS\\|FROM\\|IMPORT\\)\\>"
 205      (1 font-lock-keyword-face)
 206      (font-lock-match-c-style-declaration-item-and-skip-to-next
 207       nil (goto-char (match-end 0))
 208       (1 font-lock-constant-face)))
 209     ;;
 210     ;; Pragmas as warnings.
 211     ;; Spencer Allain <sallain@teknowledge.com> says do them as comments...
 212     ;; ("<\\*.*\\*>" . font-lock-warning-face)
 213     ;; ... but instead we fontify the first word.
 214     ("<\\*[ \t]*\\(\\sw+\\)" 1 font-lock-warning-face prepend)
 215     )
 216   "Subdued level highlighting for Modula-3 modes.")
 217
 218 (defconst m3-font-lock-keywords-2
 219   (append m3-font-lock-keywords-1
 220    (eval-when-compile
 221      (let ((m3-types
 222             (regexp-opt
 223              '("INTEGER" "BITS" "BOOLEAN" "CARDINAL" "CHAR" "FLOAT" "REAL"
 224                "LONGREAL" "REFANY" "ADDRESS" "ARRAY" "SET" "TEXT"
 225                "MUTEX" "ROOT" "EXTENDED")))
 226            (m3-keywords
 227             (regexp-opt
 228              '("AND" "ANY" "AS" "BEGIN" "BRANDED" "BY" "CASE" "CONST" "DIV"
 229                "DO" "ELSE" "ELSIF" "EVAL" "EXCEPT" "EXIT" "FINALLY"
 230                "FOR" "GENERIC" "IF" "IN" "LOCK" "LOOP" "METHODS" "MOD" "NOT"
 231                "OBJECT" "OF" "OR" "OVERRIDES" "READONLY" "RECORD" "REF"
 232                "REPEAT" "RETURN" "REVEAL" "THEN" "TO" "TRY"
 233                "TYPE" "TYPECASE" "UNSAFE" "UNTIL" "UNTRACED" "VAR" "VALUE"
 234                "WHILE" "WITH")))
 235            (m3-builtins
 236             (regexp-opt
 237              '("ABS" "ADR" "ADRSIZE" "BITSIZE" "BYTESIZE" "CEILING"
 238                "DEC" "DISPOSE" "FIRST" "FLOOR" "INC" "ISTYPE" "LAST"
 239                "LOOPHOLE" "MAX" "MIN" "NARROW" "NEW" "NUMBER" "ORD"
 240                "ROUND" "SUBARRAY" "TRUNC" "TYPECODE" "VAL")))
 241            )
 242        (list
 243         ;;
 244         ;; Keywords except those fontified elsewhere.
 245         (concat "\\<\\(" m3-keywords "\\)\\>")
 246         ;;
 247         ;; Builtins.
 248         (cons (concat "\\<\\(" m3-builtins "\\)\\>") 'font-lock-builtin-face)
 249         ;;
 250         ;; Type names.
 251         (cons (concat "\\<\\(" m3-types "\\)\\>") 'font-lock-type-face)
 252         ;;
 253         ;; Fontify tokens as function names.
 254         '("\\<\\(END\\|EXCEPTION\\|RAISES?\\)\\>[ \t{]*"
 255           (1 font-lock-keyword-face)
 256           (font-lock-match-c-style-declaration-item-and-skip-to-next
 257            nil (goto-char (match-end 0))
 258            (1 font-lock-function-name-face)))
 259         ;;
 260         ;; Fontify constants as references.
 261         '("\\<\\(FALSE\\|NIL\\|NULL\\|TRUE\\)\\>" . font-lock-constant-face)
 262         ))))
 263   "Gaudy level highlighting for Modula-3 modes.")
 264
 265 (defvar m3-font-lock-keywords m3-font-lock-keywords-1
 266   "Default expressions to highlight in Modula-3 modes.")
 267
 268 ;; We don't actually have different keywords for Modula-2.  Volunteers?
 269 (defconst m2-font-lock-keywords-1 m3-font-lock-keywords-1
 270   "Subdued level highlighting for Modula-2 modes.")
 271
 272 (defconst m2-font-lock-keywords-2 m3-font-lock-keywords-2
 273   "Gaudy level highlighting for Modula-2 modes.")
 274
 275 (defvar m2-font-lock-keywords m2-font-lock-keywords-1
 276   "Default expressions to highlight in Modula-2 modes.")
 277 \f
 278 (defun m2-newline ()
 279   "Insert a newline and indent following line like previous line."
 280   (interactive)
 281   (let ((hpos (current-indentation)))
 282     (newline)
 283     (indent-to hpos)))
 284
 285 (defun m2-tab ()
 286   "Indent to next tab stop."
 287   (interactive)
 288   (indent-to (* (1+ (/ (current-indentation) m2-indent)) m2-indent)))
 289
 290 (defun m2-begin ()
 291   "Insert a BEGIN keyword and indent for the next line."
 292   (interactive)
 293   (insert "BEGIN")
 294   (m2-newline)
 295   (m2-tab))
 296
 297 (defun m2-case ()
 298   "Build skeleton CASE statement, prompting for the <expression>."
 299   (interactive)
 300   (let ((name (read-string "Case-Expression: ")))
 301     (insert "CASE " name " OF")
 302     (m2-newline)
 303     (m2-newline)
 304     (insert "END (* case " name " *);"))
 305   (end-of-line 0)
 306   (m2-tab))
 307
 308 (defun m2-definition ()
 309   "Build skeleton DEFINITION MODULE, prompting for the <module name>."
 310   (interactive)
 311   (insert "DEFINITION MODULE ")
 312   (let ((name (read-string "Name: ")))
 313     (insert name ";\n\n\n\nEND " name ".\n"))
 314   (previous-line 3))
 315
 316 (defun m2-else ()
 317   "Insert ELSE keyword and indent for next line."
 318   (interactive)
 319   (m2-newline)
 320   (backward-delete-char-untabify m2-indent ())
 321   (insert "ELSE")
 322   (m2-newline)
 323   (m2-tab))
 324
 325 (defun m2-for ()
 326   "Build skeleton FOR loop statement, prompting for the loop parameters."
 327   (interactive)
 328   (insert "FOR ")
 329   (let ((name (read-string "Loop Initialiser: ")) limit by)
 330     (insert name " TO ")
 331     (setq limit (read-string "Limit: "))
 332     (insert limit)
 333     (setq by (read-string "Step: "))
 334     (if (not (string-equal by ""))
 335         (insert " BY " by))
 336     (insert " DO")
 337     (m2-newline)
 338     (m2-newline)
 339     (insert "END (* for " name " to " limit " *);"))
 340   (end-of-line 0)
 341   (m2-tab))
 342
 343 (defun m2-header ()
 344   "Insert a comment block containing the module title, author, etc."
 345   (interactive)
 346   (insert "(*\n    Title: \t")
 347   (insert (read-string "Title: "))
 348   (insert "\n    Created:\t")
 349   (insert (current-time-string))
 350   (insert "\n    Author: \t")
 351   (insert (user-full-name))
 352   (insert (concat "\n\t\t<" (user-login-name) "@" (system-name) ">\n"))
 353   (insert "*)\n\n"))
 354
 355 (defun m2-if ()
 356   "Insert skeleton IF statement, prompting for <boolean-expression>."
 357   (interactive)
 358   (insert "IF ")
 359   (let ((thecondition (read-string "<boolean-expression>: ")))
 360     (insert thecondition " THEN")
 361     (m2-newline)
 362     (m2-newline)
 363     (insert "END (* if " thecondition " *);"))
 364   (end-of-line 0)
 365   (m2-tab))
 366
 367 (defun m2-loop ()
 368   "Build skeleton LOOP (with END)."
 369   (interactive)
 370   (insert "LOOP")
 371   (m2-newline)
 372   (m2-newline)
 373   (insert "END (* loop *);")
 374   (end-of-line 0)
 375   (m2-tab))
 376
 377 (defun m2-module ()
 378   "Build skeleton IMPLEMENTATION MODULE, prompting for <module-name>."
 379   (interactive)
 380   (insert "IMPLEMENTATION MODULE ")
 381   (let ((name (read-string "Name: ")))
 382     (insert name ";\n\n\n\nEND " name ".\n")
 383     (previous-line 3)
 384     (m2-header)
 385     (m2-type)
 386     (newline)
 387     (m2-var)
 388     (newline)
 389     (m2-begin)
 390     (m2-begin-comment)
 391     (insert " Module " name " Initialisation Code "))
 392   (m2-end-comment)
 393   (newline)
 394   (m2-tab))
 395
 396 (defun m2-or ()
 397   (interactive)
 398   (m2-newline)
 399   (backward-delete-char-untabify m2-indent)
 400   (insert "|")
 401   (m2-newline)
 402   (m2-tab))
 403
 404 (defun m2-procedure ()
 405   (interactive)
 406   (insert "PROCEDURE ")
 407   (let ((name (read-string "Name: " ))
 408         args)
 409     (insert name " (")
 410     (insert (read-string "Arguments: ") ")")
 411     (setq args (read-string "Result Type: "))
 412     (if (not (string-equal args ""))
 413         (insert " : " args))
 414     (insert ";")
 415     (m2-newline)
 416     (insert "BEGIN")
 417     (m2-newline)
 418     (m2-newline)
 419     (insert "END ")
 420     (insert name)
 421     (insert ";")
 422     (end-of-line 0)
 423     (m2-tab)))
 424
 425 (defun m2-with ()
 426   (interactive)
 427   (insert "WITH ")
 428   (let ((name (read-string "Record-Type: ")))
 429     (insert name)
 430     (insert " DO")
 431     (m2-newline)
 432     (m2-newline)
 433     (insert "END (* with " name " *);"))
 434   (end-of-line 0)
 435   (m2-tab))
 436
 437 (defun m2-record ()
 438   (interactive)
 439   (insert "RECORD")
 440   (m2-newline)
 441   (m2-newline)
 442   (insert "END (* record *);")
 443   (end-of-line 0)
 444   (m2-tab))
 445
 446 (defun m2-stdio ()
 447   (interactive)
 448   (insert "
 449 FROM TextIO IMPORT
 450    WriteCHAR, ReadCHAR, WriteINTEGER, ReadINTEGER,
 451    WriteCARDINAL, ReadCARDINAL, WriteBOOLEAN, ReadBOOLEAN,
 452    WriteREAL, ReadREAL, WriteBITSET, ReadBITSET,
 453    WriteBasedCARDINAL, ReadBasedCARDINAL, WriteChars, ReadChars,
 454    WriteString, ReadString, WhiteSpace, EndOfLine;
 455
 456 FROM SysStreams IMPORT sysIn, sysOut, sysErr;
 457
 458 "))
 459
 460 (defun m2-type ()
 461   (interactive)
 462   (insert "TYPE")
 463   (m2-newline)
 464   (m2-tab))
 465
 466 (defun m2-until ()
 467   (interactive)
 468   (insert "REPEAT")
 469   (m2-newline)
 470   (m2-newline)
 471   (insert "UNTIL ")
 472   (insert (read-string "<boolean-expression>: ") ";")
 473   (end-of-line 0)
 474   (m2-tab))
 475
 476 (defun m2-var ()
 477   (interactive)
 478   (m2-newline)
 479   (insert "VAR")
 480   (m2-newline)
 481   (m2-tab))
 482
 483 (defun m2-while ()
 484   (interactive)
 485   (insert "WHILE ")
 486   (let ((name (read-string "<boolean-expression>: ")))
 487     (insert name " DO" )
 488     (m2-newline)
 489     (m2-newline)
 490     (insert "END (* while " name " *);"))
 491   (end-of-line 0)
 492   (m2-tab))
 493
 494 (defun m2-export ()
 495   (interactive)
 496   (insert "EXPORT QUALIFIED "))
 497
 498 (defun m2-import ()
 499   (interactive)
 500   (insert "FROM ")
 501   (insert (read-string "Module: "))
 502   (insert " IMPORT "))
 503
 504 (defun m2-begin-comment ()
 505   (interactive)
 506   (if (not (bolp))
 507       (indent-to comment-column 0))
 508   (insert "(*  "))
 509
 510 (defun m2-end-comment ()
 511   (interactive)
 512   (if (not (bolp))
 513       (indent-to m2-end-comment-column))
 514   (insert "*)"))
 515
 516 (defun m2-compile ()
 517   (interactive)
 518   (compile (concat m2-compile-command " " (buffer-name))))
 519
 520 (defun m2-link ()
 521   (interactive)
 522   (if m2-link-name
 523       (compile (concat m2-link-command " " m2-link-name))
 524     (compile (concat m2-link-command " "
 525                      (setq m2-link-name (read-string "Name of executable: "
 526                                                      (buffer-name)))))))
 527
 528 (defun m2-execute-monitor-command (command)
 529   (let* ((shell shell-file-name)
 530          (csh (equal (file-name-nondirectory shell) "csh")))
 531     (call-process shell nil t t "-cf" (concat "exec " command))))
 532
 533 (defun m2-visit ()
 534   (interactive)
 535   (let ((deffile nil)
 536         (modfile nil)
 537         modulename)
 538     (save-excursion
 539       (setq modulename
 540             (read-string "Module name: "))
 541       (switch-to-buffer "*Command Execution*")
 542       (m2-execute-monitor-command (concat "m2whereis " modulename))
 543       (goto-char (point-min))
 544       (condition-case ()
 545           (progn (re-search-forward "\\(.*\\.def\\) *$")
 546                  (setq deffile (buffer-substring (match-beginning 1)
 547                                                  (match-end 1))))
 548         (search-failed ()))
 549       (condition-case ()
 550           (progn (re-search-forward "\\(.*\\.mod\\) *$")
 551                  (setq modfile (buffer-substring (match-beginning 1)
 552                                                  (match-end 1))))
 553         (search-failed ()))
 554       (if (not (or deffile modfile))
 555           (error "I can find neither definition nor implementation of %s"
 556                  modulename)))
 557     (cond (deffile
 558             (find-file deffile)
 559             (if modfile
 560                 (save-excursion
 561                   (find-file modfile))))
 562           (modfile
 563            (find-file modfile)))))
 564
 565 (defun m2-toggle ()
 566   "Toggle between .mod and .def files for the module."
 567   (interactive)
 568   (cond ((string-equal (substring (buffer-name) -4) ".def")
 569          (find-file-other-window
 570           (concat (substring (buffer-name) 0 -4) ".mod")))
 571         ((string-equal (substring (buffer-name) -4) ".mod")
 572          (find-file-other-window
 573           (concat (substring (buffer-name) 0 -4)  ".def")))
 574         ((string-equal (substring (buffer-name) -3) ".mi")
 575          (find-file-other-window
 576           (concat (substring (buffer-name) 0 -3)  ".md")))
 577         ((string-equal (substring (buffer-name) -3) ".md")
 578          (find-file-other-window
 579           (concat (substring (buffer-name) 0 -3)  ".mi")))))
 580
 581 (provide 'modula2)
 582
 583 ;;; modula2.el ends here