Navigation Menu

Skip to content

Instantly share code, notes, and snippets.

@Edward-H

Edward-H/cobol-mode.el

Last active March 12, 2024 22:14
Show Gist options
  • Star 10 You must be signed in to star a gist
  • Fork 2 You must be signed in to fork a gist
  • Save Edward-H/6768e7dc53ea3dd2adca to your computer and use it in GitHub Desktop.
Save Edward-H/6768e7dc53ea3dd2adca to your computer and use it in GitHub Desktop.
Download ZIP
An Emacs mode for COBOL code. It features syntax highlighting for most modern dialects, indentation, support for free- and fixed-format code and code skeletons.
Raw
cobol-mode.el
;;; cobol-mode.el --- Mode for editing COBOL code -*- lexical-binding: t; -*-
;; Copyright (C) 2013-2017 Edward Hart
;; Author: Edward Hart <edward.dan.hart@gmail.com>
;; Maintainer: Edward Hart
;; Version: 1.0.0
;; Created: 9 November 2013
;; Keywords: languages
;;; This program is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file should not be confused with Rick Bielawski's cobol-mode.el
;; (http://www.emacswiki.org/emacs/cobol-mode.el), which this mode attempts to
;; supersede.
;; This COBOL mode features syntax highlighting for most modern COBOL dialects,
;; indentation, code skeletons, rulers and basic formatting functions.
;; Highlighting changes with the code format, which can be specified using the
;; M-x customize menu.
;;; Installation:
;; To install cobol-mode.el, save it to your .emacs.d/ directory and add the
;; following to your .emacs:
;; (autoload 'cobol-mode "cobol-mode" "Major mode for highlighting COBOL files." t nil)
;; To automatically load cobol-mode.el upon opening COBOL files, add this:
;; (setq auto-mode-alist
;; (append
;; '(("\\.cob\\'" . cobol-mode)
;; ("\\.cbl\\'" . cobol-mode)
;; ("\\.cpy\\'" . cobol-mode))
;; auto-mode-alist))
;; Finally, I strongly suggest installing auto-complete-mode, which makes typing
;; long keywords and variable names a thing of the past. See
;; https://github.com/auto-complete/auto-complete.
;;; Known bugs:
;; * Switching source formats requires M-x customize settings to be changed,
;; saved and cobol-mode to be unloaded then reloaded.
;; * Copying-and-pasting content in fixed-format sometimes results in content
;; being pasted in column 1 and spaces inserted in the middle of it.
;; * The indentation code leaves a lot of trailing whitespace.
;; * Periods on their own line are sometimes indented strangely.
;; * String continuation does not work.
;;; Missing features:
;; * Switch between dialect's reserved word lists via M-x customize (without
;; unloading cobol-mode).
;; * Allow users to modify easily reserved word lists.
;; * Expand copybooks within a buffer.
;; * String continuation (see above).
;; * Allow users to modify start of program-name area.
;;; Code:
(eval-when-compile
(require 'cl-lib))
(defgroup cobol nil
"Major mode for editing COBOL code."
:link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
:prefix 'cobol-
:group 'languages)
(defun cobol--radio-of-list (list)
"Return radio with the elements of LIST as its arguments."
(cons 'radio (mapcar #'(lambda (elt) (list 'const elt)) list)))
(defun cobol--val-in-list-p (list)
"Return a predicate to check whether a value is in the LIST."
#'(lambda (value) (memq value list)))
(defcustom cobol-declaration-clause-indent 40
"Column to indent data division declaration clauses to."
:type 'integer
:safe 'integerp
:group 'cobol)
(defconst cobol-formats
'(fixed-85 fixed-2002 free)
"The accepted values for `cobol-source-format'.")
(defcustom cobol-source-format 'fixed-85
"Source format of COBOL source code."
:type (cobol--radio-of-list cobol-formats)
:safe (cobol--val-in-list-p cobol-formats)
:group 'cobol)
;; Ruler
;; Code derived from the Emacs fortran.el, rulers from IBM Rational Developer.
(defcustom cobol-fixed-85-ruler
"----+-*A-1-B--+----2----+----3----+----4----+----5----+----6----+----7--|-+----\n"
"Ruler for COBOL-85-style fixed format code."
:type 'string
:safe 'stringp
:group 'cobol)
(defcustom cobol-fixed-2002-ruler
"----+-*--1----+----2----+----3----+----4----+----5----+----6----+----7----+----\n"
"Ruler for COBOL-2002-style fixed format code."
:type 'string
:safe 'stringp
:group 'cobol)
(defcustom cobol-free-ruler
"----+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----\n"
"Ruler for free format code."
:type 'string
:safe 'stringp
:group 'cobol)
(defun cobol-column-ruler ()
"Insert a column ruler above the current line until the next keystroke.
The next key typed is executed unless it is SPC."
(interactive)
(momentary-string-display
(cond ((eq cobol-source-format 'fixed-85)
cobol-fixed-85-ruler)
((eq cobol-source-format 'fixed-2002)
cobol-fixed-2002-ruler)
((eq cobol-source-format 'free)
cobol-free-ruler))
(save-excursion
(beginning-of-line)
(if (eq (window-start (selected-window))
(window-point (selected-window)))
(line-beginning-position 2)
(point)))
nil "Type SPC or any command to erase the ruler."))
(defcustom cobol-mode-hook nil
"Hook run by `cobol-mode'."
:type 'hook
:group 'cobol)
(defun cobol--remove-strings (l1 l2)
"Return a list of strings in L1 not in L2."
(cl-set-difference l1 l2 :test #'string-equal))
(defconst cobol-directives
'("CALL-CONVENTION"
"D"
"DEFINE"
"ELIF"
"ELSE"
"END-EVALUATE"
"END-IF"
"EVALUATE"
"FLAG-02"
"FLAG-85"
"FLAG-NATIVE-ARITHMETIC"
"IF"
"IMP"
"LEAP-SECOND"
"LISTING"
"PAGE"
"PROPAGATE"
"SOURCE"
"TURN"
"WHEN")
"List of COBOL compiler directives.")
(defconst cobol-verbs-74
'("GO TO"
"NEXT SENTENCE"
"ACCEPT"
"ADD"
"ALTER"
"CALL"
"CANCEL"
"CLOSE"
"COPY"
"COMPUTE"
"DELETE"
"DISABLE"
"DISPLAY"
"DIVIDE"
"ENABLE"
"ENTER"
"EXIT"
"GENERATE"
"GO"
"IF"
"INITIATE"
"INSPECT"
"MERGE"
"MOVE"
"MULTIPLY"
"OPEN"
"PERFORM"
"READ"
"RECEIVE"
"RELEASE"
"RESET"
"RETURN"
"REWRITE"
"SEARCH"
"SELECT"
"SEND"
"SET"
"SORT"
"START"
"STOP"
"STRING"
"SUBTRACT"
"SUPPRESS"
"TERMINATE"
"UNSTRING"
"USE"
"WRITE"))
(defconst cobol-verbs-85
(append cobol-verbs-74
'("CONTINUE"
"EVALUATE"
"INITIALIZE"
"REPLACE")))
(defconst cobol-removed-verbs-2002
'("ALTER" "ENTER"))
(defconst cobol-verbs-2002
(append (cobol--remove-strings cobol-verbs-85 cobol-removed-verbs-2002)
'("ALLOCATE"
"FREE"
"GOBACK"
"INVOKE"
"RAISE"
"RESUME"
"UNLOCK"
"VALIDATE")))
(defconst cobol-removed-verbs-2014
'("DISABLE"
"ENABLE"
"SEND"
"RECEIVE"))
(defconst cobol-verbs-2014
(cobol--remove-strings cobol-verbs-2002
cobol-removed-verbs-2014))
(defconst cobol-verbs-extensions
'("DELETE FILE"
"READY TRACE"
"RESET TRACE"
"XML GENERATE"
"XML PARSE"
"ATTACH"
"ALLOW" ; Unisys COBOL-74
"AWAIT-OPEN" ; Unisys COBOL-74
"CAUSE" ; Unisys COBOL-74
"CHAIN"
"CHANGE" ; Unisys COBOL-74
"COLOR"
"COMMIT"
"CREATE"
"DECLARE"
"DELEGATE"
"DETACH"
"DISALLOW" ; Unisys COBOL-74
"ENTRY"
"EXAMINE"
"EXEC"
"EXECUTE"
"EXHIBIT"
;; "LOCK" ; Unisys COBOL-74 ; Treated as keyword
"MODIFY"
"NOTE"
"ON" ; OS/VS Statement ; Keyword <= COBOL-74
"PROCESS" ; Unisys COBOL-74
"RESPOND" ; Unisys COBOL-74
"ROLLBACK"
;; "RUN" ; Unisys COBOL-74 ; Treated as keyword
"SEEK" ; Unisys COBOL-74
"SERVICE"
"SYNC" ; <= COBOL-74
"TRANSFORM"
"TRY"
"WAIT"))
(defconst cobol-verbs
(append cobol-verbs-2014
cobol-removed-verbs-2002
cobol-removed-verbs-2014
cobol-verbs-extensions)
"List of COBOL verb keywords.")
(defconst cobol-scope-terminators-85
'("END-ADD"
"END-CALL"
"END-COMPUTE"
"END-DELETE"
"END-DIVIDE"
"END-EVALUATE"
"END-IF"
"END-MULTIPLY"
"END-PERFORM"
"END-READ"
"END-RECEIVE"
"END-RETURN"
"END-REWRITE"
"END-SEARCH"
"END-START"
"END-STRING"
"END-SUBTRACT"
"END-UNSTRING"
"END-WRITE"))
(defconst cobol-scope-terminators-2002
(append cobol-scope-terminators-85
'("END-ACCEPT"
"END-DISPLAY")))
(defconst cobol-removed-scope-terminators-2014
'("END-RECEIVE"))
(defconst cobol-scope-terminators-2014
(cobol--remove-strings cobol-scope-terminators-2002
cobol-removed-scope-terminators-2014))
(defconst cobol-scope-terminators-xml-tr
'("END-OPEN"))
(defconst cobol-scope-terminators-extensions
'("END-CHAIN"
"END-COLOR"
"END-DELEGATE"
"END-EXEC"
"END-INVOKE"
"END-MODIFY"
"END-MOVE"
"END-SYNC"
"END-TRY"
"END-WAIT"
"END-XML"))
(defconst cobol-scope-terminators
(append cobol-scope-terminators-2014
cobol-scope-terminators-xml-tr
cobol-scope-terminators-extensions))
(defconst cobol-keywords-74
'("ACCESS"
"ADVANCING"
"AFTER"
"ALL"
"ALPHABETIC"
"ALSO"
"ALTERNATE"
"AND"
"ARE"
"AREA"
"AREAS"
"ASCENDING"
"ASSIGN"
"AT"
"AUTHOR"
"BEFORE"
"BLANK"
"BLOCK"
"BOTTOM"
"BY"
"CD"
"CF"
"CH"
"CHARACTER"
"CHARACTERS"
"CLOCK-UNITS"
"COBOL"
"CODE"
"CODE-SET"
"COLLATING"
"COLUMN"
"COMMA"
"COMMUNICATION"
"COMP"
"COMPUTATIONAL"
"CONFIGURATION"
"CONTAINS"
"CONTROL"
"CONTROLS"
"CORR"
"CORRESPONDING"
"COUNT"
"CURRENCY"
"DATA"
"DATE"
"DATE-COMPILED"
"DATE-WRITTEN"
"DAY"
"DE"
"DEBUG-CONTENTS"
"DEBUG-ITEM"
"DEBUG-LINE"
"DEBUG-NAME"
"DEBUG-SUB-1"
"DEBUG-SUB-2"
"DEBUG-SUB-3"
"DEBUGGING"
"DECIMAL-POINT"
"DECLARATIVES"
"ENVIRONMENT"
"DELIMITED"
"DELIMITER"
"DEPENDING"
"DESCENDING"
"DESTINATION"
"DETAIL"
"DIVISION"
"DOWN"
"DUPLICATES"
"DYNAMIC"
"EGI"
"ELSE"
"EMI"
"END"
"END-OF-PAGE"
"EOP"
"EQUAL"
"ERROR"
"ESI"
"EVERY"
"EXCEPTION"
"EXTEND"
"FD"
"FILE"
"FILE-CONTROL"
"FILLER"
"FINAL"
"FIRST"
"FOOTING"
"FOR"
"FROM"
"GIVING"
"GREATER"
"GROUP"
"HEADING"
"I-O"
"I-O-CONTROL"
"IDENTIFICATION"
"INDEX"
"INDEXED"
"IN"
"INDICATE"
"INITIAL"
"INPUT"
"INPUT-OUTPUT"
"INSTALLATION"
"INTO"
"INVALID"
"IS"
"JUST"
"JUSTIFIED"
"KEY"
"LABEL"
"LAST"
"LEADING"
"LEFT"
; LENGTH is treated as an intrinsic function.
"LESS"
"LIMIT"
"LIMITS"
"LINAGE"
"LINAGE-COUNTER"
"LINE"
"LINE-COUNTER"
"LINES"
"LINKAGE"
"LOCK"
"NEXT"
"MEMORY"
"MESSAGE"
"MODE"
"MODULES"
"MULTIPLE"
"NATIVE"
"NEGATIVE"
"NO"
"NOT"
"NUMBER"
"NUMERIC"
"OBJECT-COMPUTER"
"OCCURS"
"OF"
"OFF"
"OMITTED"
;; "ON" ; OS/VS Statement ; Keyword <= COBOL-74
"OPTIONAL"
"OR"
"ORGANIZATION"
"OUTPUT"
"OVERFLOW"
"PAGE"
"PAGE-COUNTER"
"PF"
"PH"
"PIC"
"PICTURE"
"PLUS"
"POINTER"
"POSITION"
"POSITIVE"
"PRINTING"
"PROCEDURE"
"PROCEDURES"
"PROCEED"
"PROGRAM"
"PROGRAM-ID"
"QUEUE"
"RANDOM"
"RD"
"RECORD"
"RECORDS"
"REDEFINES"
"REEL"
"REFERENCES"
"RELATIVE"
"REMAINDER"
"REMOVAL"
"RENAMES"
"REPLACING"
"REPORT"
"REPORTING"
"REPORT"
"RERUN"
"RESERVE"
"REVERSED"
"REWIND"
"RF"
"RH"
"RIGHT"
"ROUNDED"
"RUN"
"SAME"
"SD"
"SECTION"
"SECURITY"
"SEGMENT"
"SEGMENT-LIMIT"
"SEND"
"SENTENCE"
"SEPARATE"
"SEQUENCE"
"SEQUENTIAL"
"SIZE"
"SORT-MERGE"
"SOURCE"
"SOURCE-COMPUTER"
"SPECIAL-NAMES"
"STANDARD"
"STANDARD-1"
"STATUS"
"SUB-QUEUE-1"
"SUB-QUEUE-2"
"SUB-QUEUE-3"
"SYMBOLIC"
"SYNCHRONIZED"
"TABLE"
"TALLYING"
"TAPE"
"TERMINAL"
"TEXT"
"THAN"
"THROUGH"
"THRU"
"TIME"
"TIMES"
"TO"
"TOP"
"TRAILING"
"TYPE"
"UNIT"
"UNTIL"
"UP"
"UPON"
"USAGE"
"USING"
"VALUE"
"VALUES"
"VARYING"
"WHEN"
"WITH"
"WORDS"
"WORKING-STORAGE"))
(defconst cobol-keywords-85
(append cobol-keywords-74
'("ALPHABET"
"ALPHABETIC-LOWER"
"ALPHABETIC-UPPER"
"ALPHANUMERIC"
"ALPHANUMERIC-EDITED"
"ANY"
"BINARY"
"CLASS"
"COMMON"
"CONTENT"
"CONVERTING"
"DAY-OF-WEEK"
"EXTERNAL"
"FALSE"
"FUNCTION"
"GLOBAL"
"NUMERIC-EDITED"
"ORDER"
"OTHER"
"PACKED-DECIMAL"
"PADDING"
"PURGE"
"REFERENCE"
"STANDARD-2"
"TEST"
"THEN"
"TRUE")))
(defconst cobol-removed-keywords-2002
'("AUTHOR"
"INSTALLATION"
"DATE-WRITTEN"
"DATE-COMPILED"
"SECURITY"
"MEMORY"
"RERUN"
"MULTIPLE"
"TAPE"
"LABEL"
"REVERSED"
"DEBUG-CONTENTS"
"DEBUG-ITEM"
"DEBUG-LINE"
"DEBUG-NAME"
"DEBUG-SUB-1"
"DEBUG-SUB-2"
"DEBUG-SUB-3"))
(defconst cobol-keywords-2002
(append (cobol--remove-strings cobol-keywords-85
cobol-removed-keywords-2002)
'("ACTIVE-CLASS"
"ADDRESS"
"ALIGNED"
"ANYCASE"
"AS"
"B-AND"
"B-NOT"
"B-OR"
"B-XOR"
"BASED"
"BINARY-CHAR"
"BINARY-DOUBLE"
"BINARY-LONG"
"BINARY-SHORT"
"BIT"
"BOOLEAN"
"CLASS-ID"
"COL"
"COLS"
"COLUMNS"
"CONDITION"
"CONSTANT"
"CRT"
"CURSOR"
"DATA-POINTER"
"DEFAULT"
"EC"
"EO"
"EXCEPTION-OBJECT"
"FACTORY"
"FLOAT-EXTENDED"
"FLOAT-LONG"
"FLOAT-SHORT"
"FORMAT"
"FUNCTION-ID"
"GET"
"GROUP-USAGE"
"INHERITS"
"INTERFACE"
"INTERFACE-ID"
"LAST"
"LOCAL-STORAGE"
"LOCALE"
"METHOD"
"METHOD-ID"
"MINUS"
"NATIONAL"
"NATIONAL-EDITED"
"NESTED"
"OBJECT"
"OBJECT-REFERENCE"
"OPTIONS"
"OVERRIDE"
"PRESENT"
"PROGRAM-POINTER"
"PROPERTY"
"PROTOTYPE"
"RAISING"
"REPOSITORY"
"RETRY"
"RETURNING"
"SCREEN"
"SHARING"
"SOURCES"
"SYSTEM-DEFAULT"
"TYPEDEF"
"UNIVERSAL"
"USER-DEFAULT"
"VAL-STATUS"
"VALID"
"VALIDATE-STATUS")))
(defconst cobol-keywords-finalizer-tr
'("AUTO-METHOD"))
(defconst cobol-keywords-xml-tr
'("DOCUMENT"
"IDENTIFIED"
"VERSION-XML"))
(defconst cobol-removed-keywords-2014
'("CD"
"DEBUGGING"
"EGI"
"EMI"
"ESI"
"MESSAGE"
"PADDING"
"PURGE"
"QUEUE"
"SEGMENT"
"SUB-QUEUE-1"
"SUB-QUEUE-2"
"SUB-QUEUE-3"
"TERMINAL"
"TEXT"))
(defconst cobol-keywords-2014
(append (cobol--remove-strings cobol-keywords-2002
cobol-removed-keywords-2014)
'("FARTHEST-FROM-ZERO"
"FLOAT-BINARY-32"
"FLOAT-BINARY-64"
"FLOAT-BINARY-128"
"FLOAT-DECIMAL-16"
"FLOAT-DECIMAL-34"
"FLOAT-INFINITY"
"FLOAT-NOT-A-NUMBER"
"FLOAT-NOT-A-NUMBER-QUIET"
"FLOAT-NOT-A-NUMBER-SIGNALING"
"FUNCTION-POINTER"
"IN-ARITHMETIC-RANGE"
"NEAREST-TO-ZERO")))
(defconst cobol-keywords-extensions
'("3-D"
"ABSENT"
"ABSTRACT"
"ACQUIRE"
"ACTION"
"ACTIVE-X"
"ACTUAL"
"ACCEPT-CLOSE"
"ACCEPT-OPEN"
"ADDRESS-ARRAY"
"ADDRESS-OFFSET"
"ADJUSTABLE-COLUMNS"
"AFP-5A"
"ALIGNMENT"
"ALLOWING"
"ANY LENGTH"
"APPLY"
"ARGUMENT-NUMBER"
"ARGUMENT-VALUE"
"ASSEMBLY-ATTRIBUTES"
"ASSOCIATED-DATA" ; Unisys
"ASSOCIATED-DATA-LENGTH" ; Unisys
"AUTO-DECIMAL"
"AUTO-HYPHEN-SKIP"
"AUTO-MINIMIZE"
"AUTO-RESIZE"
"AUTO-SKIP"
"AUTO-SPIN"
"AUTOTERMINATE"
"AX-EVENT-LIST"
"B-EXOR"
"B-LEFT"
"B-RIGHT"
"BACKGROUND-COLOUR"
"BACKGROUND-HIGH"
"BACKGROUND-LOW"
"BACKGROUND-STANDARD"
"BACKWARD"
"BAR"
"BASIS"
"BEEP"
"BEGINNING"
"BINARY-INT"
"BINARY-LONG-LONG"
"BIND"
"BITMAP"
"BITMAP-END"
"BITMAP-HANDLE"
"BITMAP-NUMBER"
"BITMAP-RAW-HEIGHT"
"BITMAP-RAW-WIDTH"
"BITMAP-SCALE"
"BITMAP-START"
"BITMAP-TIMER"
"BITMAP-TRAILING"
"BITMAP-WIDTH"
"BLINKING"
"BLOB"
"BLOB-FILE"
"BLOB-LOCATOR"
"BOLD"
"BOX"
"BOXED"
"BROWSING"
"BULK-ADDITION"
"BUSY"
"BUTTONS"
"C01"
"C02"
"C03"
"C04"
"C05"
"C06"
"C07"
"C08"
"C09"
"C10"
"C11"
"C12"
"CALENDAR-FONT"
"CALLED"
"CANCEL-BUTTON"
"CATCH"
"CBL"
"CBL-CTR"
"CCOL"
"CELL"
"CELL-COLOR"
"CELL-DATA"
"CELL-FONT"
"CELL-PROTECTION"
"CELLS"
"CENTERED"
"CENTERED-HEADINGS"
"CENTURY-DATE"
"CENTURY-DAY"
"CHAINING"
"CHANGED"
"CHAR-VARYING"
"CHART"
"CHECK-BOX"
"CHECKING"
"CLASS-ATTRIBUTES"
"CLASS-CONTROL"
"CLASS-OBJECT"
"CLEAR-SELECTION"
"CLINE"
"CLINES"
"CLOB"
"CLOB-FILE"
"CLOB-LOCATOR"
"CLOSE-DISPOSITION" ; Unisys
"CMP" ; Unisys
"COERCION"
"COLORS"
"COLOUR"
"COLOURS"
"COLUMN-COLOR"
"COLUMN-DIVIDERS"
"COLUMN-FONT"
"COLUMN-HEADINGS"
"COLUMN-PROTECTION"
"COM-REG"
"COMBO-BOX"
"COMMAND-LINE"
"COMMITMENT"
"COMP-0"
"COMP-1"
"COMP-2"
"COMP-3"
"COMP-4"
"COMP-5"
"COMP-6"
"COMP-N"
"COMP-X"
"COMPRESSION"
"COMPUTATIONAL-0"
"COMPUTATIONAL-1"
"COMPUTATIONAL-2"
"COMPUTATIONAL-3"
"COMPUTATIONAL-4"
"COMPUTATIONAL-5"
"COMPUTATIONAL-6"
"COMPUTATIONAL-N"
"COMPUTATIONAL-X"
"CONDITION-VALUE"
"CONNECT-TIME-LIMIT" ; Unisys
"CONSOLE"
"CONSTRAIN"
"CONSTRAINTS"
"CONTROL-AREA"
"CONTROL-POINT" ; Unisys
"CONTROLS-UNCROPPED"
"CONVENTION"
"CONVERSION"
"CONVERT"
"COPY-SELECTION"
"CORE-INDEX"
"CP" ; Unisys
"CREATING"
"CRT-UNDER"
"CRUNCH" ; Unisys
"CSIZE"
"CSP"
"CURSOR-COL"
"CURSOR-COLOR"
"CURSOR-FRAME-WIDTH"
"CURSOR-ROW"
"CURSOR-X"
"CURSOR-Y"
"CUSTOM-ATTRIBUTE"
"CUSTOM-PRINT-TEMPLATE"
"CYL-INDEX"
"CYL-OVERFLOW"
"DASHED"
"DATA-COLUMNS"
"DATA-TYPES"
"DATABASE-KEY"
"DATABASE-KEY-LONG"
"DATE-ENTRY"
"DATE-RECORD"
"DBCLOB"
"DBCLOB-FILE"
"DBCLOB-LOCATOR"
"DBCS"
"DEBUG"
"DECIMAL"
"DEFAULT-BUTTON"
"DEFAULT-FONT"
"DEFINITION"
"DELEGATE-ID"
"DESTROY"
"DICTIONARY"
"DISC"
"DISJOINING"
"DISK"
"DISP"
"DISPLAY-1"
"DISPLAY-COLUMNS"
"DISPLAY-FORMAT"
"DISPLAY-ST"
"DIVIDER-COLOR"
"DIVIDERS"
"DONT-PARTICIPATE" ; Unisys
"DOT-DASH"
"DOTTED"
"DOUBLE"
"DRAG-COLOR"
"DRAW"
"DROP"
"DROP-DOWN"
"DROP-LIST"
"EBCDIC"
"ECHO"
"EGCS"
"EJECT"
"ELEMENTARY"
"EMPTY-CHECK"
"ENABLED"
"ENCRYPTION"
"ENDING"
"ENGRAVED"
"ENSURE-VISIBLE"
"ENTRY-FIELD"
"ENTRY-REASON"
"ENUM"
"ENUM-ID"
"ENVIRONMENT-NAME"
"ENVIRONMENT-VALUE"
"EQUALS"
"ESCAPE"
"ESCAPE-BUTTON"
"EVENT"
"EVENT-LIST"
"EVENT-POINTER"
"EXCEEDS"
"EXCEPTION-VALUE"
"EXCESS-3"
"EXCLUDE-EVENT-LIST"
"EXCLUSIVE"
"EXPAND"
"EXTENDED"
"EXTENDED-SEARCH"
"EXTENSION"
"EXTERNAL-FORM"
"EXTERNALLY-DESCRIBED-KEY"
"FH--FCD"
"FH--KEYDEF"
"FILE-ID"
"FILE-LIMIT"
"FILE-LIMITS"
"FILE-NAME"
"FILE-POS"
"FILL-COLOR"
"FILL-COLOR2"
"FILL-PERCENT"
"FINALLY"
"FINISH-REASON"
"FIXED"
"FIXED-FONT"
"FIXED-WIDTH"
"FLAT"
"FLAT-BUTTONS"
"FLOAT"
"FLOATING"
"FONT"
"FOREGROUND-COLOUR"
"FRAME"
"FRAMED"
"FULL-HEIGHT"
"GETTER"
"GO-BACK"
"GO-FORWARD"
"GO-HOME"
"GO-SEARCH"
"GRAPHICAL"
"GRID"
"GRIP"
"GROUP-VALUE"
"HANDLE"
"HAS-CHILDREN"
"HEADING-COLOR"
"HEADING-DIVIDER-COLOR"
"HEADING-FONT"
"HEAVY"
"HEIGHT"
"HEIGHT-IN-CELLS"
"HELP-ID"
"HIDDEN-DATA"
"HIGH"
"HIGH-COLOR"
"HORIZONTAL"
"HOT-TRACK"
"HSCROLL"
"HSCROLL-POS"
"ICON"
"ID"
"IGNORE"
"INDEPENDENT"
"INDEXED"
"INDEXER"
"INDEXER-ID"
"INDIC"
"INDICATOR"
"INDICATORS"
"INDIRECT"
"INHERITING"
"INQUIRE"
"INTERRUPT"
"INSERT"
"INSERT-ROWS"
"INSERTION-INDEX"
"INSTANCE"
"INTERNAL"
"INVOKED"
"ITEM"
"ITEM-BOLD"
"ITEM-ID"
"ITEM-TEXT"
"ITEM-TO-ADD"
"ITEM-TO-DELETE"
"ITEM-TO-EMPTY"
"ITEM-VALUE"
"ITERATOR"
"ITERATOR-ID"
"JOINED"
"JOINING"
"KANJI"
"KEPT"
"KEY-YY"
"KEYBOARD"
"LABEL-OFFSET"
"LARGE-FONT"
"LAST-ROW"
"LAYOUT-DATA"
"LAYOUT-MANAGER"
"LEADING-SHIFT"
"LEAVE"
"LEFT-JUSTIFY"
"LEFT-TEXT"
"LEFTLINE"
"LENGTH-CHECK"
"LENGTH OF"
"LIN"
"LINES-AT-ROOT"
"LINK"
"LIST"
"LIST-BOX"
"LM-RESIZE"
"LANGUAGE"
"LOCAL" ; Unisys
"LOCKING"
"LONG-DATE"
"LONG-VARBINARY"
"LONG-VARCHAR"
"LOW"
"LOW-COLOR"
"LOWER"
"LOWER-BOUND" ; Unisys
"LOWER-BOUNDS" ; Unisys
"LOWERED"
"MASS-UPDATE"
"MASTER-INDEX"
"MAX-HEIGHT"
"MAX-LINES"
"MAX-PROGRESS"
"MAX-SIZE"
"MAX-TEXT"
"MAX-VAL"
"MAX-WIDTH"
"MDI-CHILD"
"MDI-FRAME"
"MEDIUM-FONT"
"MENU"
"MESSAGES"
"METACLASS"
"MIN-HEIGHT"
"MIN-LINES"
"MIN-SIZE"
"MIN-VAL"
"MIN-WIDTH"
"MMDDYYYY" ; Unisys
"MODAL"
"MODELESS"
"MODIFIED"
"MONITOR-POINTER"
"MORE-DATA" ; Unisys
"MORE-LABELS"
"MULTILINE"
"MUTEX-POINTER"
"MYJOB" ; Unisys
"MYSELF" ; Unisys
"NAME"
"NAMED"
"NAVIGATE-URL"
"NCHAR"
"NET-EVENT-LIST"
"NEW"
"NEWABLE"
"NEXT-ITEM"
"NO-AUTO-DEFAULT"
"NO-AUTOSEL"
"NO-BOX"
"NO-CELL-DRAG"
"NO-CLOSE"
"NO-DIVIDERS"
"NO-ECHO"
"NO-F4"
"NO-FOCUS"
"NO-GROUP-TAB"
"NO-KEY-LETTER"
"NO-SEARCH"
"NO-TAB"
"NO-UPDOWN"
"NOMINAL"
"NOTIFY"
"NOTIFY-CHANGE"
"NOTIFY-DBLCLICK"
"NOTIFY-SELCHANGE"
"NSTD-REELS"
"NUM-COL-HEADINGS"
"NUM-ROW-HEADINGS"
"NUM-ROWS"
"NUMERIC-DATE" ; Unisys
"NUMERIC-FILL"
"NUMERIC-TIME" ; Unisys
"O-FILL"
"OBJECT-ID"
"OBJECT-STORAGE"
"OC" ; Unisys
"ODT-INPUT-PRESENT" ; Unisys
"OK-BUTTON"
"OOSTACKPTR"
"OPERATOR"
"OPERATOR-ID"
"OTHERWISE"
"OVERLAP-LEFT"
"OVERLAP-TOP"
"OVERLAPPED"
"OVERLINE"
"OWN" ; Unisys
"PAGE-SETUP"
"PAGE-SIZE"
"PAGED"
"PANEL-INDEX"
"PANEL-STYLE"
"PANEL-TEXT"
"PANEL-WIDTHS"
"PARAMS"
"PARENT"
"PARSE"
"PARTIAL"
"PARTICIPATE" ; Unisys
"PASSWORD"
"PC" ; Unisys
"PERMANENT"
"PIXEL"
"PIXELS"
"PLACEMENT"
"POP-UP"
"POSITION-SHIFT"
"POSITIONING"
"PREFIXING"
"PRINT"
"PRINT-CONTROL"
"PRINT-NO-PROMPT"
"PRINT-PREVIEW"
"PRINT-SWITCH"
"PRINTER"
"PRINTER-1"
"PRIOR"
"PRIORITY"
"PRIVATE"
"PROCEDURE-POINTER"
"PROCESSING"
"PROGRESS"
"PROMPT"
"PROPERTIES"
"PROPERTY-ID"
"PROPERTY-VALUE"
"PROTECTED"
"PUBLIC"
"PUSH-BUTTON"
"QUERY-INDEX"
"RADIO-BUTTON"
"RAISED"
"READ-OK" ; Unisys
"READ-ONLY"
"READING"
"READY"
"REAL" ; Unisys
"RECORD-DATA"
"RECORD-OVERFLOW"
"RECORD-TO-ADD"
"RECORD-TO-DELETE"
"RECORDING"
"REDEFINE"
"REDEFINITION"
"REF" ; Unisys
"REFRESH"
"REGION-COLOR"
"REJECT-OPEN"
"RELOAD"
"REMARKS"
"REORG-CRITERIA"
"REPEATED"
"REREAD"
"RESET"
"RESET-GRID"
"RESET-LIST"
"RESET-TABS"
"RESIDENT"
"RESIZABLE"
"RESTRICTED"
"RESULT-SET-LOCATOR"
"RETURN-CODE"
"RIGHT-ALIGN"
"RIGHT-JUSTIFY"
"RIMMED"
"ROLLING"
"ROW-COLOR"
"ROW-COLOR-PATTERN"
"ROW-DIVIDERS"
"ROW-FONT"
"ROW-HEADINGS"
"ROW-PROTECTION"
"ROWID"
"S01"
"S02"
"S03"
"S04"
"S05"
"SAVE-AS"
"SAVE-AS-NO-PROMPT"
"SCROLL"
"SCROLL-BAR"
"SEARCH-OPTIONS"
"SEARCH-TEXT"
"SELECT-ALL"
"SELECTION-INDEX"
"SELECTION-TEXT"
"SELECTIVE"
"SELF-ACT"
"SELFCLASS"
"SEMAPHORE-POINTER"
"SEPARATION"
"SETTER"
"SHADING"
"SHADOW"
"SHIFT-IN"
"SHIFT-OUT"
"SHORT-DATE"
"SHOW-LINES"
"SHOW-NONE"
"SHOW-SEL-ALWAYS"
;; SIGN is treated as an intrinsic function.
"SIGNED-INT"
"SIGNED-LONG"
"SIGNED-SHORT"
"SKIP1"
"SKIP2"
"SKIP3"
"SMALL-FONT"
"SORT-CONTROL"
"SORT-CORE-SIZE"
"SORT-FILE-SIZE"
"SORT-MESSAGE"
"SORT-MODE-SIZE"
"SORT-OPTION"
"SORT-ORDER"
"SORT-RETURN"
"SORT-TAPE"
"SORT-TAPES"
"SPACE-FILL"
"SPINNER"
"SQL"
"SQUARE"
"STANDARD-3"
"START-X"
"START-Y"
"STARTING"
"STATIC"
"STATIC-LIST"
"STATIONLIST"
"STATUS-BAR"
"STATUS-TEXT"
"STDCALL"
"STOP-BROWSER"
"STYLE"
"SUBFILE"
"SUBWINDOW"
"SUFFIXING"
;; SUM is an intrinsic function.
"SW0"
"SW1"
"SW2"
"SW3"
"SW4"
"SW5"
"SW6"
"SW7"
"SW8"
"SW9"
"SW10"
"SW11"
"SW12"
"SW13"
"SW14"
"SW15"
"SWITCH-0"
"SWITCH-1"
"SWITCH-2"
"SWITCH-3"
"SWITCH-4"
"SWITCH-5"
"SWITCH-6"
"SWITCH-7"
"SWITCH-8"
"SWITCH-9"
"SWITCH-10"
"SWITCH-11"
"SWITCH-12"
"SWITCH-13"
"SWITCH-14"
"SWITCH-15"
"SYSIN"
"SYSIPT"
"SYSLST"
"SYSOUT"
"SYSPCH"
"SYSPUNCH"
"SYSTEM"
"SYSTEM-INFO"
"TAB"
"TAB-CONTROL"
"TAB-TO-ADD"
"TAB-TO-DELETE"
"TAG-KEY" ; Unisys
"TAG-SEARCH" ; Unisys
"TALLY"
"TAPES"
"TASK"
"TEMPORARY"
"TERMINAL-INFO"
"TERMINATION-VALUE"
"THREAD"
"THREAD-LOCAL"
"THREAD-LOCAL-STORAGE"
"THREAD-POINTER"
"THUMB-POSITION"
"TILED-HEADINGS"
"TIME-OF-DAY"
"TIME-OUT"
"TIME-RECORD"
"TIMEOUT"
"TIMER" ; Unisys
"TIMESTAMP"
"TIMESTAMP-OFFSET"
"TIMESTAMP-OFFSET-RECORD"
"TIMESTAMP-RECORD"
"TITLE"
"TITLE-BAR"
"TITLE-POSITION"
"TODAYS-DATE"
"TODAYS-NAME"
"TOOL-BAR"
"TOTALED"
"TOTALING"
"TRACE"
"TRACK-AREA"
"TRACK-LIMIT"
"TRACK-THUMB"
"TRACKS"
"TRADITIONAL-FONT"
"TRAILING-SHIFT"
"TRAILING-SIGN"
"TRANSACTION"
"TRANSPARENT"
"TRANSPARENT-COLOR"
"TREE-VIEW"
"UNDERLINED"
"UNEQUAL"
"UNFRAMED"
"UNITS"
"UNSIGNED-INT"
"UNSIGNED-LONG"
"UNSIGNED-SHORT"
"UNSORTED"
"UPDATE"
"UPPER"
"UPSI-0"
"UPSI-1"
"UPSI-2"
"UPSI-3"
"UPSI-4"
"UPSI-5"
"UPSI-6"
"UPSI-7"
"URGENT"
"USE-ALT"
"USE-RETURN"
"USE-TAB"
"USER"
"USER-COLORS"
"USER-GRAY"
"USER-WHITE"
"VA" ; Unisys
"VALUE-FORMAT"
"VALUETYPE"
"VALUETYPE-ID"
"VARBINARY"
"VARIABLE"
"VARIANT"
"VERTICAL"
"VERY-HEAVY"
"VIRTUAL-WIDTH"
"VISIBLE"
"VPADDING"
"VSCROLL"
"VSCROLL-BAR"
"VSCROLL-POS"
"VTOP"
"WEB-BROWSER"
"WHERE"
"WIDTH"
"WIDTH-IN-CELLS"
"WINDOW"
"WRAP"
"WRITE-ONLY"
"WRITE-VERIFY"
"WRITING"
"XML"
"XML-CODE"
"XML-EVENT"
"XML-NTEXT"
"XML-TEXT"
"YIELDING"
"ZERO-FILL"))
(defvar cobol-keywords
(append cobol-keywords-2014
cobol-removed-keywords-2002
cobol-removed-keywords-2014
cobol-keywords-finalizer-tr
cobol-keywords-xml-tr
cobol-keywords-extensions
cobol-scope-terminators
cobol-removed-scope-terminators-2014)
"List of COBOL keywords.")
(defconst cobol-context-sensitive-keywords-2002
'("ARITHMETIC"
"ATTRIBUTE"
"AUTO"
"AUTOMATIC"
"BACKGROUND-COLOR"
"BELL"
"BLINK"
"BYTE-LENGTH"
"CENTER"
"CLASSIFICATION"
"CYCLE"
"EC-ALL"
"EC-ARGUMENT"
"EC-ARGUMENT-FUNCTION"
"EC-ARGUMENT-IMP"
"EC-BOUND"
"EC-BOUND-IMP"
"EC-BOUND-ODO"
"EC-BOUND-OVERFLOW"
"EC-BOUND-PTR"
"EC-BOUND-REF-MOD"
"EC-BOUND-SET"
"EC-BOUND-SUBSCRIPT"
"EC-BOUND-TABLE-LIMIT"
"EC-DATA"
"EC-DATA-CONVERSION"
"EC-DATA-IMP"
"EC-DATA-INCOMPATIBLE"
"EC-DATA-INTEGRITY"
"EC-DATA-PTR-NULL"
"EC-FLOW"
"EC-FLOW-GLOBAL-EXIT"
"EC-FLOW-GLOBAL-GOBACK"
"EC-FLOW-IMP"
"EC-FLOW-RELEASE"
"EC-FLOW-REPORT"
"EC-FLOW-RETURN"
"EC-FLOW-SEARCH"
"EC-FLOW-USE"
"EC-FUNCTION"
"EC-FUNCTION-PTR-INVALID"
"EC-FUNCTION-PTR-NULL"
"EC-I-O"
"EC-I-O-AT-END"
"EC-I-O-EOP"
"EC-I-O-EOP-OVERFLOW"
"EC-I-O-FILE-SHARING"
"EC-I-O-IMP"
"EC-I-O-INVALID-KEY"
"EC-I-O-LINAGE"
"EC-I-O-LOGIC-ERROR"
"EC-I-O-PERMANENT-ERROR"
"EC-I-O-RECORD-OPERATION"
"EC-IMP"
;; EC-IMP-suffix is matched separately by
;; cobol-implementor-user-exception-re.
"EC-LOCALE"
"EC-LOCALE-IMP"
"EC-LOCALE-INCOMPATIBLE"
"EC-LOCALE-INVALID"
"EC-LOCALE-INVALID-PTR"
"EC-LOCALE-MISSING"
"EC-LOCALE-SIZE"
"EC-OO"
"EC-OO-CONFORMANCE"
"EC-OO-EXCEPTION"
"EC-OO-IMP"
"EC-OO-METHOD"
"EC-OO-NULL"
"EC-OO-RESOURCE"
"EC-OO-UNIVERSAL"
"EC-ORDER"
"EC-ORDER-IMP"
"EC-ORDER-NOT-SUPPORTED"
"EC-OVERFLOW"
"EC-OVERFLOW-IMP"
"EC-OVERFLOW-STRING"
"EC-OVERFLOW-UNSTRING"
"EC-PROGRAM"
"EC-PROGRAM-ARG-MISMATCH"
"EC-PROGRAM-ARG-OMITTED"
"EC-PROGRAM-CANCEL-ACTIVE"
"EC-PROGRAM-IMP"
"EC-PROGRAM-NOT-FOUND"
"EC-PROGRAM-PTR-NULL"
"EC-PROGRAM-RECURSIVE-CALL"
"EC-PROGRAM-RESOURCES"
"EC-RAISING"
"EC-RAISING-IMP"
"EC-RAISING-NOT-SPECIFIED"
"EC-RANGE"
"EC-RANGE-IMP"
"EC-RANGE-INDEX"
"EC-RANGE-INSPECT-SIZE"
"EC-RANGE-INVALID"
"EC-RANGE-PERFORM-VARYING"
"EC-RANGE-PTR"
"EC-RANGE-SEARCH-INDEX"
"EC-RANGE-SEARCH-NO-MATCH"
"EC-REPORT"
"EC-REPORT-ACTIVE"
"EC-REPORT-COLUMN-OVERLAP"
"EC-REPORT-FILE-MODE"
"EC-REPORT-IMP"
"EC-REPORT-INACTIVE"
"EC-REPORT-LINE-OVERLAP"
"EC-REPORT-NOT-TERMINATED"
"EC-REPORT-PAGE-LIMIT"
"EC-REPORT-PAGE-WIDTH"
"EC-REPORT-SUM-SIZE"
"EC-REPORT-VARYING"
"EC-SCREEN"
"EC-SCREEN-FIELD-OVERLAP"
"EC-SCREEN-IMP"
"EC-SCREEN-ITEM-TRUNCATED"
"EC-SCREEN-LINE-NUMBER"
"EC-SCREEN-STARTING-COLUMN"
"EC-SIZE"
"EC-SIZE-ADDRESS"
"EC-SIZE-EXPONENTIATION"
"EC-SIZE-IMP"
"EC-SIZE-OVERFLOW"
"EC-SIZE-TRUNCATION"
"EC-SIZE-UNDERFLOW"
"EC-SIZE-ZERO-DIVIDE"
"EC-SORT-MERGE"
"EC-SORT-MERGE-ACTIVE"
"EC-SORT-MERGE-FILE-OPEN"
"EC-SORT-MERGE-IMP"
"EC-SORT-MERGE-RELEASE"
"EC-SORT-MERGE-RETURN"
"EC-SORT-MERGE-SEQUENCE"
"EC-STORAGE"
"EC-STORAGE-IMP"
"EC-STORAGE-NOT-ALLOC"
"EC-STORAGE-NOT-AVAIL"
"EC-USER"
;; EC-USER-suffix is matched separately by
;; cobol-implementor-user-exception-re.
"EC-VALIDATE"
"EC-VALIDATE-CONTENT"
"EC-VALIDATE-FORMAT"
"EC-VALIDATE-IMP"
"EC-VALIDATE-RELATION"
"EC-VALIDATE-VARYING"
"EOL"
"EOS"
"ENTRY-CONVENTION"
"ERASE"
"EXPANDS"
"FOREGROUND-COLOR"
"FOREVER"
"FULL"
"HIGHLIGHT"
"IGNORING"
"IMPLEMENTS"
"INITIALIZED"
"INTRINSIC"
"LC_ALL"
"LC_COLLATE"
"LC_CTYPE"
"LC_MESSAGES"
"LC_MONETARY"
"LC_NUMERIC"
"LC_TIME"
"LOWLIGHT"
"MANUAL"
"MULTIPLE" ; <= COBOL-74
"NEGATIVE-INFINITY"
"NONE"
"NORMAL"
"NUMBERS"
"ONLY"
"PARAGRAPH"
"POSITIVE-INFINITY"
"PREVIOUS"
"RECURSIVE"
"RELATION"
"REQUIRED"
"REVERSE-VIDEO"
"SECONDS"
"SECURE"
"STATEMENT"
"STEP"
"STRONG"
"SYMBOL"
"UCS-4"
"UNDERLINE"
"UNSIGNED"
"UTF-8"
"UTF-16"
;; XML is treated as a reserved word per IBM implementations.
"YYYYDDD"
"YYYYMMDD"))
(defconst cobol-context-sensitive-keywords-finalizer-tr
'("EC-OO-FINALIZABLE"
"FINALIZER"))
(defconst cobol-context-sensitive-keywords-xml-tr
'("CHECK"
"DISCARD"
"DOCUMENTATION"
"DTD"
"EC-DATA-INFINITY"
"EC-DATA-NEGATIVE-INFINITY"
"EC-DATA-NOT-A-NUMBER"
"EC-XML"
"EC-XML-CODESET"
"EC-XML-CODESET-CONVERSION"
"EC-XML-COUNT"
"EC-XML-DOCUMENT-TYPE"
"EC-XML-IMPLICIT-CLOSE"
"EC-XML-INVALID"
"EC-XML-NAMESPACE"
"EC-XML-STACKED-OPEN"
"EC-XML-RANGE"
"ELEMENT"
"NAMESPACE"
"RAW"
"SCHEMA"
"STACK"
"VALIDITY"))
(defconst cobol-context-sensitive-keywords-2014
(append cobol-context-sensitive-keywords-2002
'("AWAY-FROM-ZERO"
"BINARY-ENCODING"
"CAPACITY"
"DECIMAL-ENCODING"
"EC-FUNCTION-ARG-OMITTED"
"EC-FUNCTION-NOT-FOUND"
"EC-OO-ARG-OMITTED"
"FLOAT-BINARY"
"FLOAT-DECIMAL"
"HIGH-ORDER-LEFT"
"HIGH-ORDER-RIGHT"
"INTERMEDIATE"
"NEAREST-AWAY-FROM-ZERO"
"NEAREST-EVEN-INTERMEDIATE"
"NEAREST-TOWARD-ZERO"
"PREFIXED"
"PROHIBITED"
"ROUNDING"
"SHORT"
"SIGNED"
"STANDARD-BINARY"
"STANDARD-DECIMAL"
"TOWARD-GREATER"
"TOWARD-LESSER"
"TRUNCATION")))
(defconst cobol-context-sensitive-extensions
'("TRUNCATED" ; Unisys
))
(defvar cobol-context-sensitive-keywords
(append cobol-context-sensitive-keywords-2014
cobol-context-sensitive-keywords-finalizer-tr
cobol-context-sensitive-keywords-xml-tr
cobol-context-sensitive-extensions)
"List of context-sensitive COBOL keywords.")
(defconst cobol-intrinsics-85
'("ACOS"
"ANNUITY"
"ASIN"
"ATAN"
;; BYTE-LENGTH is treated as a context-sensitive word.
"CHAR"
"COS"
"CONCATENATE"
"CURRENT-DATE"
"DATE-OF-INTEGER"
"DAY-OF-INTEGER"
"FACTORIAL"
"INTEGER"
"INTEGER-OF-DATE"
"INTEGER-OF-DAY"
"INTEGER-PART"
"LENGTH"
"LOG"
"LOG10"
"LOWER-CASE"
"MAX"
"MEAN"
"MEDIAN"
"MIDRANGE"
"MIN"
"MOD"
"NUMVAL"
"NUMVAL-C"
"ORD"
"ORD-MAX"
"ORD-MIN"
"PRESENT-VALUE"
;; RANDOM is treated as a keyword
"RANGE"
"REM"
"REVERSE"
"SIGN" ; Keyword <= COBOL-74
"SIN"
"SQRT"
"STANDARD-DEVIATION"
"SUM" ; Keyword <= COBOL-74
"TAN"
"UPPER-CASE"
"VARIANCE"
"WHEN-COMPILED"))
(defconst cobol-intrinsics-2002
(append cobol-intrinsics-85
'("ABS"
"BOOLEAN-OF-INTEGER"
"CHAR-NATIONAL"
"DATE-TO-YYYYMMDD"
"DAY-TO-YYYYDDD"
"DISPLAY-OF"
"E"
"EXCEPTION-FILE"
"EXCEPTION-FILE-N"
"EXCEPTION-LOCATION"
"EXCEPTION-LOCATION-N"
"EXCEPTION-STATEMENT"
"EXCEPTION-STATUS"
"EXP"
"EXP10"
"FRACTION-PART"
"HIGHEST-ALGEBRAIC"
"INTEGER-OF-BOOLEAN"
"LOCALE-COMPARE"
"LOCALE-DATE"
"LOCALE-TIME"
"LOWEST-ALGEBRAIC"
"NATIONAL-OF"
"NUMVAL-F"
"PI"
"STANDARD-COMPARE"
"TEST-DATE-YYYYMMDD"
"TEST-DAY-YYYYDDD"
"TEST-NUMVAL"
"TEST-NUMVAL-C"
"TEST-NUMVAL-F"
"YEAR-TO-YYYY")))
(defconst cobol-intrinsics-2014
(append cobol-intrinsics-2002
'("COMBINED-DATETIME"
"FORMATTED-CURRENT-DATE"
"FORMATTED-DATE"
"FORMATTED-DATETIME"
"FORMATTED-TIME"
"INTEGER-OF-FORMATTED-DATE"
"LOCALE-TIME-FROM-SECONDS"
"SECONDS-FROM-FORMATTED-TIME"
"SECONDS-PAST-MIDNIGHT"
"TEST-FORMATTED-DATETIME"
"TRIM")))
(defconst cobol-intrinsics-extensions
'("ADDR"
"CURRENCY-SYMBOL"
"LENGTH-AN"
"MODULE-CALLER-ID"
"MODULE-DATE"
"MODULE-FORMATTED-DATE"
"MODULE-ID"
"MODULE-PATH"
"MODULE-SOURCE"
"MONETARY-DECIMAL-POINT"
"MONETARY-THOUSANDS-SEPARATOR"
"NUMERIC-DECIMAL-POINT"
"NUMERIC-THOUSANDS-SEPARATOR"
"STORED-CHAR-LENGTH"
"SUBSTITUTE"
"SUBSTITUTE-CASE"
"ULENGTH"
"UPOS"
"USUBSTR"
"USUPPLEMENTARY"
"UVALID"
"UWIDTH"))
(defvar cobol-intrinsics
(append cobol-intrinsics-2014
cobol-intrinsics-extensions)
"List of COBOL standard functions.")
(defconst cobol-symbolic-literals-74
'("HIGH-VALUE"
"HIGH-VALUES"
"LOW-VALUE"
"LOW-VALUES"
"QUOTE"
"QUOTES"
"SPACE"
"SPACES"
"ZERO"
"ZEROES"
"ZEROS"))
(defconst cobol-symbolic-literals-85
cobol-symbolic-literals-74)
(defconst cobol-symbolic-literals-2002
(append cobol-symbolic-literals-85
'("NULL"
"SELF"
"SUPER")))
(defconst cobol-symbolic-literals-2014
cobol-symbolic-literals-2002)
(defconst cobol-symbolic-literals-extensions
'("NULLS"))
(defvar cobol-symbolic-literals
(append cobol-symbolic-literals-2014
cobol-symbolic-literals-extensions)
"List of COBOL symbolic literals.")
(defface cobol-verb
'((t (:inherit font-lock-keyword-face :weight bold)))
"Face for COBOL verbs."
:group 'cobol)
(defface cobol-context-sensitive
'((t (:inherit font-lock-keyword-face)))
"Face for context-sensitive COBOL words."
:group 'cobol)
;;; Highlighting regexps
(defconst cobol--fixed-form-sequence-area-re
"^.\\{1,6\\}"
"Regexp matching the fixed-form sequence area.")
(defconst cobol--complete-sequence-area-re
"^.\\{6\\}"
"Regexp matching a complete sequence area.")
(defconst cobol--fixed-comment-indicators-re
"*/"
"Regexp containing COBOL fixed-form comment indicators.")
(defconst cobol--fixed-form-comment-re
(concat cobol--complete-sequence-area-re
"\\(["
cobol--fixed-comment-indicators-re
"]\\)")
"Regexp matching a fixed-form source comment.")
(defconst cobol--continuation-or-debugging-indicator-re
(concat cobol--complete-sequence-area-re
"\\([d-]\\)")
"Regexp matching a continuation or debugging line indicator.")
(defconst cobol--non-fixed-comment-indicators-re
(concat "[^" cobol--fixed-comment-indicators-re "]")
"Regexp matching non-fixed-form-comment-indicator characters.")
(defconst cobol--fixed-non-comment-sequence-area-re
(concat cobol--complete-sequence-area-re
cobol--non-fixed-comment-indicators-re)
"Regexp matching the sequence area of a non-comment fixed-form line.")
(defconst cobol--fixed-non-comment-grouped-sequence-area-re
(concat "\\(" cobol--fixed-form-sequence-area-re "\\)")
"Regexp matching the sequence area of a non-comment fixed-form line in a
group.")
(defconst cobol--fixed-form-areas-02-re
cobol--fixed-non-comment-grouped-sequence-area-re
"Regexp matching the ignored fixed-forms area in COBOL 2002 for non-comment
lines.")
(defconst cobol--fixed-form-areas-85-re
(concat cobol--fixed-non-comment-grouped-sequence-area-re
".\\{0,66\\}\\(.*\\)")
"Regexp matching the ignored fixed-form areas up to COBOL-85 for non-comment
lines.")
(defconst cobol--fixed-form-wrong-indicator-re
(concat cobol--fixed-form-sequence-area-re "\\([^-\\*/d$]\\)")
"Regexp matching incorrect indicators in fixed-form code.")
(defconst cobol--free-form-comment-re
"\\*>.*"
"Regexp matching a free-form source comment.")
(defconst cobol--optional-whitespace-re
"[ ]*" ; Space and tab
"Regexp matching optional whitespace. \\w isn't used to avoid matching
newlines.")
(defconst cobol--optional-leading-whitespace-line-re
(if (not (eq cobol-source-format 'free))
(concat cobol--fixed-non-comment-sequence-area-re
cobol--optional-whitespace-re)
(concat "^" cobol--optional-whitespace-re))
"Regexp matching a line perhaps starting with whitespace.")
(defun cobol--with-opt-whitespace-line (&rest strs)
"Return STRS concatenated after `cobol--optional-leading-whitespace-line-re'."
(apply #'concat (cons cobol--optional-leading-whitespace-line-re strs)))
(defconst cobol--free-form-comment-line-re
(cobol--with-opt-whitespace-line cobol--free-form-comment-re)
"Regexp matching a free form comment line.")
(defconst cobol--identifier-re
"\\s-+\\(\\w+\\)"
"Regexp matching an identifier in a separate group preceded by whitespace.")
(defconst cobol--mf-set-directive
(cobol--with-opt-whitespace-line "$SET\\s-+\\w+")
"Regexp matching MF compiler directive with optional whitespace.")
(defconst cobol--mf-compiler-directive-re
(if (not (eq cobol-source-format 'free))
(concat cobol--fixed-form-sequence-area-re
cobol--mf-set-directive)
(concat "^" cobol--mf-set-directive))
"Regexp matching Micro Focus compiler directives.")
(defconst cobol--standard-constant-re
(cobol--with-opt-whitespace-line "0?1" cobol--identifier-re "\\s-+CONSTANT")
"Regexp matching constants declared as specified by the 2002 standard.")
(defconst cobol--mf-constant-re
(cobol--with-opt-whitespace-line "78" cobol--identifier-re)
"Regexp matching constants declared as specified by Micro Focus.")
(defconst cobol--directive-indicator-re
">> ?"
"Regexp matching a valid directive indicator.")
(defconst cobol--define-directive-re
(cobol--with-opt-whitespace-line cobol--directive-indicator-re
"DEFINE"
cobol--identifier-re)
"Regexp matching values defined by the pre-processor.")
(defconst cobol--descriptor-level-re
"[FRS]D"
"Regexp matching file/report/sort descriptor 'level numbers'.")
(defconst cobol--record-descriptor-re
(cobol--with-opt-whitespace-line cobol--descriptor-level-re cobol--identifier-re)
"Regexp matching file/report/sort record associations.")
(defconst cobol--typedef-definition-re
(cobol--with-opt-whitespace-line "0?1" cobol--identifier-re ".+TYPEDEF")
"Regexp matching typedefs.")
(defconst cobol--level-number-re
"[[:digit:]]\\{1,2\\}"
"Regexp matching level numbers.")
(defconst cobol--variable-declaration-re
(cobol--with-opt-whitespace-line cobol--level-number-re cobol--identifier-re)
"Regexp matching standard variable declarations.")
(defconst cobol--mf-declare-variable-re
(cobol--with-opt-whitespace-line "DECLARE" cobol--identifier-re)
"Regexp matching variable declarations using DECLARE verb used in Managed
COBOL.")
(defconst cobol--id-and-name-re
"-ID\\.?\\s-*\\(\\w+\\)"
"Regexp matching a construct ID and the name of the declared construct.")
(defun cobol--create-id-re (re)
"Create an id regexp using RE."
(cobol--with-opt-whitespace-line re cobol--id-and-name-re))
(defun cobol--create-end-marker-re (re)
"Create an end marker regexp using RE."
(cobol--with-opt-whitespace-line "END\\s-+" re cobol--identifier-re))
(defconst cobol--standard-function-types
'("FUNCTION" "METHOD" "PROGRAM")
"List containing the names of standard constructs similar to functions.")
(defconst cobol--mf-function-types
'("ITERATOR" "OPERATOR" "PROPERTY")
"List containing the names of constructs similar to functions created by Micro
Focus.")
(defconst cobol--function-types-re
(regexp-opt (append cobol--standard-function-types cobol--mf-function-types))
"Regexp matching the names of constructs similar to functions.")
(defconst cobol--function-id-name-re
(cobol--create-id-re (remove "PROPERTY" cobol--function-types-re))
"Regexp matching the id and name of a function or similar.")
(defconst cobol--function-end-marker-re
(cobol--create-end-marker-re cobol--function-types-re)
"Regexp matching the end marker of a function or similar.")
(defconst cobol--standard-type-types
'("CLASS" "INTERFACE")
"List containing the standard type construct names.")
(defconst cobol--mf-type-types
'("DELEGATE" "ENUM" "INDEXER" "VALUETYPE")
"List containing the names of type constructs added by Micro Focus.")
(defconst cobol--type-types-re
(regexp-opt (append cobol--standard-type-types cobol--mf-type-types))
"Regexp matching type construct names.")
(defconst cobol--type-id-name-re
(cobol--create-id-re cobol--type-types-re)
"Regexp matching the id and name of a type.")
(defconst cobol--type-end-marker-re
(cobol--create-end-marker-re cobol--type-types-re)
"Regexp matching the end marker of a type.")
(defconst cobol--mf-property-id-name-re
(concat "PROPERTY" cobol--id-and-name-re cobol--identifier-re)
"Regexp matching the id, name and type of a property using MF's PROPERTY-ID
syntax.")
(defconst cobol--procedure-re
(cobol--with-opt-whitespace-line "\\(\\w+\\)\\(\\s-+SECTION\\)?\\.")
"Regexp matching the declaration of a procedure. Note that this matches
DECLARATIVES.")
(defconst cobol--select-file-re
(cobol--with-opt-whitespace-line
"SELECT\\(\\s-+OPTIONAL\\)?"
cobol--identifier-re)
"Regexp matching the declaration of a file.")
(defconst cobol--pic-type-re
"PIC\\(TURE\\)?\\(\\s-+IS\\)?\\s-+\\(\\([-$*+,./[:digit:]()ABENPSVXZ]\\|CR\\|DB\\)+?\\)\\(\\s-\\|\\.?
\\)"
"Regexp matching the PICTURE clause of a variable.")
(defconst cobol--string-literal-type-re
"\\([ZBN]X?\\|[GHLX]\\)\\(\"\\|\'\\)"
"Regexp matching the type of a string-style literal.")
(defconst cobol--function-call-re
"\\(\\w+\\)("
"Regexp matching a function call.")
(defun cobol--create-specifier-type-re (types)
"Create a specifier id regexp for the list of type names TYPES."
(cobol--with-opt-whitespace-line
"\\("
(mapconcat #'identity types "\\|")
"\\)"
cobol--identifier-re))
(defconst cobol--repository-function-type-clause-re
(cobol--create-specifier-type-re cobol--standard-function-types)
"Regexp matching a REPOSITORY specifier clause for function types.")
(defconst cobol--repository-type-type-clause-re
(cobol--create-specifier-type-re cobol--standard-type-types)
"Regexp matching a REPOSITORY specifier clause for type types.")
(defconst cobol--mf-invoked-class-re
(concat "TYPE" cobol--identifier-re)
"Regexp matching a class being INVOKED.")
(defconst cobol--implementer-user-exception-re
"EC-\\(IMP\\|USER\\)-\\w+"
"Regexp matching an implementor- or user-defined exception condition.")
(defconst cobol--scope-terminator-re
(cobol--with-opt-whitespace-line (regexp-opt cobol-scope-terminators 'words))
"Regexp matching a scope terminator.")
(defconst cobol--phrases-with-double-indent-after
"\\(IF\\|EVALUATE\\|WHEN\\|ELSE\\|PERFORM\\s-+\\(VARYING\\|UNTIL\\|\\(WITH\\s-+\\)?TEST\\|.+?\\s-+TIMES\\)\\)"
"Regexp matching phrases whose conditions/clauses are indented twice.")
(defconst cobol--containing-statement-or-phrase-re
(cobol--with-opt-whitespace-line
"\\("
cobol--phrases-with-double-indent-after
"\\|\\(NOT\\s-+\\)?\\(\\(AT\\s-+\\)?END\\(-OF-PAGE\\)?\\>\\|\\(ON\\s-+\\)?\\(OVERFLOW\\|EXCEPTION\\|ESCAPE\\|SIZE\\s-+ERROR\\)\\|INVALID\\s-+KEY\\)\\)")
"Regexp matching statements/phrases that contain nested statements.")
(defconst cobol--verb-re
(cobol--with-opt-whitespace-line (regexp-opt cobol-verbs 'words))
"Regexp matching a verb.")
(defconst cobol--non-id-groups
;; AUTO-METHOD is part of the Finalizer TR.
'("AUTO-METHOD" "DECLARATIVES" "FACTORY" "OBJECT" "METHOD")
"Groups which do not take a (specifiable) ID.")
(defconst cobol--non-id-group-end-marker-re
(cobol--with-opt-whitespace-line
"END\\s-+" (regexp-opt cobol--non-id-groups 'words))
"Regexp matching the end marker of the groups not taking IDs.")
(defconst cobol--end-marker-re
(concat "\\(" cobol--function-end-marker-re
"\\|" cobol--type-end-marker-re
"\\|" cobol--non-id-group-end-marker-re
"\\)")
"Regexp matching an end marker.")
(defconst cobol--division-re
(cobol--with-opt-whitespace-line "\\(IDENTIFICATION\\|ENVIRONMENT\\|DATA\\|PROCEDURE\\)\\s-+DIVISION")
"Regexp matching division header.")
(defconst cobol--procedure-division-re
(cobol--with-opt-whitespace-line "PROCEDURE\\s-+DIVISION")
"Regexp matching the procedure division header.")
(defconst cobol--env-or-data-div-sections-re
(cobol--with-opt-whitespace-line
(regexp-opt '("CONFIGURATION" "INPUT-OUTPUT" "FILE" "WORKING-STORAGE" "LOCAL-STORAGE" "LINKAGE" "REPORT" "SCREEN"))
"\\s-+SECTION.")
"Regexp matching the sections of the environment and data divisions.")
(defconst cobol--generic-declaration-re
(cobol--with-opt-whitespace-line
"\\("
cobol--descriptor-level-re
"\\|"
cobol--level-number-re
"\\)"
cobol--identifier-re)
"Regexp matching any declaration.")
(defconst cobol--blank-line-re
(cobol--with-opt-whitespace-line "\\.?$")
"Regexp matching a blank line with optional period.")
;;; Font lock
(defun cobol--fixed-format-p ()
"Return whether the current source format is fixed."
(or (eq cobol-source-format 'fixed-85)
(eq cobol-source-format 'fixed-2002)))
;; This is required for indentation to function, because the initial sequence
;; area is marked as a comment, not whitespace.
(defun cobol-back-to-indentation ()
"Move point to the first non-whitespace character on this line. If in
fixed-form code, the sequence area and indicators are skipped.
Code copied from the emacs source."
(interactive "^")
(beginning-of-line 1)
(when (cobol--fixed-format-p)
(forward-char 7))
(skip-syntax-forward " " (line-end-position))
;; Move back over chars that have whitespace syntax but have the p flag.
(backward-prefix-chars))
(defun cobol--syntax-propertize-sequence-area (beg end)
"Mark text in the program name area as comments from the lines at/after BEG up
to END."
(goto-char beg)
(while (and (< (point) end)
(re-search-forward "^.\\{1,6\\}" end t))
(add-text-properties (line-beginning-position) (point)
'(font-lock-face
font-lock-comment-face))
;; Remove face from text previously in sequence area.
(remove-text-properties (point) (line-end-position)
'(font-lock-face nil))))
(defun cobol--syntax-propertize-indicator-area (beg end)
"Mark fixed-form comments as comments between points BEG and END."
(funcall
(syntax-propertize-rules
(cobol--fixed-form-comment-re (1 "<"))
(cobol--continuation-or-debugging-indicator-re (1 ".")))
beg end))
(defun cobol--syntax-propertize-program-name-area (beg end)
"Mark text in the program name area as comments from the lines at/after BEG up
to END."
(funcall
(syntax-propertize-rules
;; TODO: Override open strings
("^.\\{72\\}\\(.\\)" (1 "<")))
beg end))
(defun cobol--syntax-propertize-page-directive (beg end)
"Mark text after >>PAGE as a comment between points BEG and END."
(funcall
(syntax-propertize-rules
((cobol--with-opt-whitespace-line cobol--directive-indicator-re
"PAGE\\([ ]\\)")
(1 "<")))
beg end))
(defun cobol--syntax-propertize-adjacent-quotes (beg end)
"Mark the first of adjacent quotes, e.g. \"\" or '', as an escape character
between points BEG and END."
(goto-char beg)
(while (and (< (point) end)
(re-search-forward "\\(\"\"\\|''\\)" end t))
;; Move to first quote.
(backward-char 2)
(if (in-string-p)
(progn
(put-text-property (point) (1+ (point))
'syntax-table (string-to-syntax "\\"))
;; Move back to past the escaped quotes.
(forward-char 2))
;; If the first quote began a string, then the next quote may be the
;; first character in another escaped quote sequence.
(forward-char 1))))
(defun cobol--syntax-propertize-function (beg end)
"Syntax propertize awkward COBOL features (fixed-form comments, indicators
and ignored areas) between points BEG and END."
;; TO-DO: Propertize continuation lines.
(when (cobol--fixed-format-p)
(cobol--syntax-propertize-sequence-area beg end)
(cobol--syntax-propertize-indicator-area beg end))
(when (eq cobol-source-format 'fixed-85)
(cobol--syntax-propertize-program-name-area beg end))
(cobol--syntax-propertize-page-directive beg end)
(cobol--syntax-propertize-adjacent-quotes beg end))
;; Chnage to defconst so it reloads on something?
(defvar cobol-font-lock-defaults
`((;; Directives
( ,(concat cobol--directive-indicator-re
"\\(" (regexp-opt cobol-directives) "\\>\\)")
. font-lock-preprocessor-face)
( ,cobol--mf-compiler-directive-re . font-lock-preprocessor-face)
;; TO-DO: Highlight reserved words in directives as reserved words
;; Standard language features.
( ,(regexp-opt cobol-verbs 'words) . 'cobol-verb)
( ,(regexp-opt cobol-keywords 'words) . font-lock-keyword-face)
( ,(regexp-opt cobol-context-sensitive-keywords 'words)
. 'cobol-context-sensitive)
( ,cobol--implementer-user-exception-re . 'cobol-context-sensitive)
( ,(regexp-opt cobol-intrinsics 'words) . font-lock-builtin-face)
;; Constants
( ,(regexp-opt cobol-symbolic-literals 'words) . font-lock-constant-face)
( ,cobol--standard-constant-re
(1 'font-lock-constant-face))
( ,cobol--mf-constant-re
(1 'font-lock-constant-face))
( ,cobol--define-directive-re
(1 'font-lock-constant-face))
;; PIC Type
( ,cobol--pic-type-re
(3 'font-lock-type-face))
;; Functions
( ,cobol--function-call-re
(1 'font-lock-function-name-face))
;; REPOSITORY clauses
( ,cobol--repository-function-type-clause-re
(2 'font-lock-function-name-face))
( ,cobol--repository-type-type-clause-re
(2 'font-lock-type-face))
;; File declarations
( ,cobol--select-file-re
(2 'font-lock-type-face))
;; File/Report/Sort record associations
( ,cobol--record-descriptor-re
(1 'font-lock-type-face))
;; Typedef
( ,cobol--typedef-definition-re
(1 'font-lock-type-face))
;; Variables
( ,cobol--variable-declaration-re
(1 'font-lock-variable-name-face))
( ,cobol--mf-declare-variable-re
(1 'font-lock-variable-name-face))
;; Construct IDs
( ,cobol--function-id-name-re
(1 'font-lock-function-name-face))
( ,cobol--type-id-name-re
(1 'font-lock-type-face))
( ,cobol--mf-property-id-name-re
(1 'font-lock-variable-name-face)
(2 'font-lock-type-face))
;; Construct end markers
( ,cobol--function-end-marker-re
(1 'font-lock-function-name-face))
( ,cobol--type-end-marker-re
(1 'font-lock-type-face))
;; Invoked classes
( ,cobol--mf-invoked-class-re
(1 'font-lock-type-face))
;; Procedures
( ,cobol--procedure-re
(1 'font-lock-function-name-face))
( ,cobol--string-literal-type-re
(1 'font-lock-string-face)))
nil
t
nil
nil))
;;; Skeletons
(define-skeleton cobol-skeleton-if-else
"Insert an IF - ELSE - END-IF block." nil
> "IF " (skeleton-read "Condition: ") > \n
> _ \n
"ELSE" > \n
> \n
"END-IF" > \n)
(define-skeleton cobol-skeleton-if
"Insert an IF - END-IF block." nil
> "IF " (skeleton-read "Condition: ") > \n
> _ \n
"END-IF" > \n)
(define-skeleton cobol-skeleton-perform-times
"Insert a PERFORM - TIMES - END-PERFORM block." nil
> "PERFORM " (skeleton-read "Number: ") " TIMES" > \n
> _ \n
"END-PERFORM" > \n)
(define-skeleton cobol-skeleton-perform-varying
"Insert a PERFORM VARYING - FROM - BY - UNTIL - END-PERFORM block."
nil
> "PERFORM VARYING "
(skeleton-read "Variable: ")
" FROM "
(skeleton-read "Start: ")
" BY "
(skeleton-read "Step: ")
" UNTIL "
(skeleton-read "Condition: ") > \n
> _ \n
"END-PERFORM" > \n)
(defun cobol-when-with-also (prompt num-also)
"Create a WHEN clause skeleton with provided PROMPT and NUM-ALSO ALSOs."
`(,prompt "WHEN " str
,@(let ((clauses nil))
(dotimes 'num-also
(setf clauses (append clauses `(" ALSO " (skeleton-read ,prompt)))))
clauses)
> \n > _ \n))
(define-skeleton cobol-skeleton-evaluate
"Insert an EVALUATE - END-EVALUATE block."
"Variable/TRUE: "
;; This is set like so because num-conds is incremented even when no str is supplied.
'(setf num-conds -1)
> "EVALUATE " str ("Variable/TRUE: " '(setf num-conds (1+ num-conds)) " ALSO " str) > \n
(cobol-when-with-also "Value/Condition: " num-conds)
"END-EVALUATE")
(define-skeleton cobol-skeleton-program
"Insert an empty PROGRAM."
"Program name: "
> "IDENTIFICATION DIVISION." > \n
"PROGRAM-ID. " str "." > \n
> \n
"DATA DIVISION." > \n
"WORKING-STORAGE SECTION." > \n
> _ \n
"PROCEDURE DIVISION." > \n
> \n
"END PROGRAM " str "." > \n)
(define-skeleton cobol-skeleton-function
"Insert an empty FUNCTION."
"Function name: "
> "IDENTIFICATION DIVISION." > \n
"FUNCTION-ID. " str "." > \n
> \n
"DATA DIVISION." > \n
"LOCAL-STORAGE SECTION." > \n
> \n
"LINKAGE SECTION." > \n
> _ \n
"PROCEDURE DIVISION RETURNING ." > \n
> \n
"END FUNCTION " str "." > \n)
(define-skeleton cobol-skeleton-method
"Insert an empty METHOD."
"Method name: "
> "IDENTIFICATION DIVISION." > \n
"METHOD-ID. " str "." > \n
> \n
"DATA DIVISION." > \n
"LOCAL-STORAGE SECTION." > \n
> _ \n
"PROCEDURE DIVISION." > \n
> \n
"END METHOD " str "." > \n)
(define-skeleton cobol-skeleton-class
"Insert an empty CLASS."
"Class name: "
> "IDENTIFICATION DIVISION." > \n
"CLASS-ID. " str "." > \n
> _ \n
"FACTORY." > \n
"END FACTORY." > \n
> \n
"OBJECT." > \n
"END OBJECT." > \n
"END CLASS " str "." > \n)
(define-skeleton cobol-skeleton-interface
"Insert an empty INTERFACE."
"Interface name: "
> "IDENTIFICATION DIVISION." > \n
"INTERFACE-ID. " str "." > \n
> _ \n
"FACTORY." > \n
"END FACTORY." > \n
> \n
"OBJECT." > \n
"END OBJECT." > \n
"END INTERFACE " str "." > \n)
;;; Code formatting
(defconst cobol-formats
'(upper-case lower-case capitalised-all capitalised-verbs)
"The different formats supported when formatting COBOL code.")
(defcustom cobol-format-style 'upper-case
"The type of formatting used when formatting COBOL code."
:type (cobol--radio-of-list cobol-formats)
:safe (cobol--val-in-list-p cobol-formats)
:group 'cobol)
(defun cobol-format-word (word)
"Return WORD formatted according to `cobol-format-style'."
(cond
((eql cobol-format-style 'upper-case)
(upcase word))
((eql cobol-format-style 'lower-case)
(downcase word))
((eql cobol-format-style 'capitalised-all)
(capitalize word))
((eql cobol-format-style 'capitalised-verbs)
(if (memq word cobol-verbs)
(capitalize word)
(downcase word)))))
(defun cobol-format-region (beg end)
"Format all COBOL words between BEG and END according to
`cobol-format-style'."
(interactive "*r")
(cobol-format beg end))
(defun cobol-format-buffer ()
"Format all COBOL words in the current buffer according to
`cobol-format-style'."
(interactive "*")
(cobol-format (point-min) (point-max)))
(defun cobol-format (beg end)
"Format COBOL code between BEG and END according to `cobol-format-style'."
(defconst words-to-format
(append cobol-directives cobol-verbs cobol-keywords cobol-intrinsics
cobol-symbolic-literals))
(save-excursion
(dolist (word words-to-format)
(let ((ref-point (point-min)))
(goto-char beg)
(while (search-forward-regexp (concat "\\<" word "\\>") end t)
(when (not (progn
(setf state (parse-partial-sexp ref-point (point)))
(or (nth 3 state) (nth 4 state))))
(replace-match (cobol-format-word word) t)))))))
;;; Fixed-form formatting
(defun cobol-insert-in-sequence-area (beg end text)
"Insert, in the lines between BEG and END, TEXT in the sequence area."
(interactive "*r\nsText: ")
(when (> (length text) 6)
(error "%s is longer than six characters" text))
(save-excursion
;; Find rectangle to insert text in.
(let (top-left bottom-right)
;; Get top left corner of rectangle.
(goto-char beg)
(beginning-of-line)
(when (< (point) beg)
(forward-line 1))
(setf top-left (point))
;; Get bottom right corner of rectangle.
(while (and (<= (+ (point) 6) end) (not (eobp)))
(forward-line 1))
(forward-line -1)
(setf bottom-right (+ (point) 6))
(string-rectangle top-left bottom-right (format "%-6s" text)))))
;;; Indentation
;;; Derived (a long time ago) from the wonderful Emacs Mode Tutorial at
;;; <http://www.emacswiki.org/emacs/ModeTutorial>.
(defun cobol--code-start ()
"Return the first column code can go in."
(if (eq cobol-source-format 'free)
0
7))
(cl-defun cobol--indent (indent &optional (times 1))
"Increment INDENT."
(+ indent (* times cobol-tab-width)))
(defun cobol--current-indentation ()
"Return the indentation of the current line or -1 if the line is within the
sequence area."
(if (< (- (line-end-position) (line-beginning-position)) (cobol--code-start))
-1
(save-excursion
(goto-char (+ (line-beginning-position) (cobol--code-start)))
(let ((code-start-position (point)))
(skip-syntax-forward " " (line-end-position))
(backward-prefix-chars)
(- (point) code-start-position)))))
(defun cobol--indent-current ()
"Return the current indent level indented once."
(cobol--indent (cobol--current-indentation)))
(defun cobol--search-back (fn)
"Go back a line at a time, calling FN each time. If the car of the return
value is non-nil, return the cdr."
(save-excursion
(do ((ret nil (funcall fn)))
((car ret) (cdr ret))
(forward-line -1))))
(cl-defun cobol--search-back-for-indent (str &key with-whitespace)
"Return the indent of the previous line starting with the regexp STR (optionally
after whitespace if WITH-WHITESPACE). If that cannot be found, return 0."
(let ((line-re (concat (when with-whitespace cobol--optional-whitespace-re)
str)))
(cobol--search-back
#'(lambda () (cond ((bobp)
(cons t 0))
((looking-at line-re)
(cons t (cobol--current-indentation))))))))
(defun cobol--indent-of-last-div ()
"Return the indent of the last division."
(cobol--search-back-for-indent cobol--division-re))
(defun cobol--indent-of-last-div-or-section ()
"Return the indent of the preceding division or section."
(cobol--search-back-for-indent "\\w+\\s-+\\(DIVISION\\|SECTION\\)\\." :with-whitespace t))
(defun cobol--indent-of-end-marker-match (group)
"Return the indent of the start of GROUP."
(if (memq (upcase group) cobol--non-id-groups)
(cobol--search-back-for-indent
(concat group ".") :with-whitespace t)
(cobol--search-back-for-indent
(cobol--create-id-re group))))
(defun cobol--match-with-leading-whitespace (re str)
"Match regexp RE (with optional leading whitespace) against STR."
(string-match (concat cobol--optional-leading-whitespace-line-re re)
str))
(defun cobol--match-line-with-leading-whitespace (re)
"Match regexp RE (with optional leading whitespace) against the current line."
(cobol--match-with-leading-whitespace re (thing-at-point 'line)))
(defun cobol--get-level-number (declaration)
"Return the level-number of DECLARATION. If the declaration does not have a
level number, return zero."
(string-match cobol--generic-declaration-re declaration)
(string-to-number (match-string 1 declaration)))
(defun cobol--indent-of-group-item (wanted-level-num)
"Return the indentation of the last item with WANTED-LEVEL-NUM or indented
from the last item of lower level."
(cobol--search-back
#'(lambda ()
(cond ((looking-at cobol--generic-declaration-re)
(let ((level-num (cobol--get-level-number (thing-at-point 'line))))
(cond ((eq level-num wanted-level-num)
(cons t (cobol--current-indentation)))
((< level-num wanted-level-num)
(cons t (cobol--indent-current))))))
((bobp)
(cons t 0))))))
(defun cobol--indent-of-declaration (decl)
"Return the indentation of the declaration DECL."
(let ((level-num (cobol--get-level-number decl)))
(if (or (>= 1 level-num) (eq 77 level-num) (eq 66 level-num))
;; If elementary item or FD/SD/RD.
(cobol--search-back-for-indent cobol--division-re)
;; Find indent of item with same level or add-indent to previous item of
;; lower level. (This means 88 levels will always be indented to the
;; previous item.)
(cobol--indent-of-group-item level-num))))
(defun cobol--indent-from-previous ()
"Return what the indent of the current line should be based on previous
lines."
(cobol--search-back
#'(lambda ()
(cond ((looking-at cobol--env-or-data-div-sections-re)
(cons t (cobol--current-indentation)))
((or (looking-at cobol--containing-statement-or-phrase-re)
(looking-at cobol--procedure-re)
(looking-at cobol--procedure-division-re))
(cons t (cobol--indent-current)))
((or (looking-at cobol--verb-re)
(looking-at cobol--scope-terminator-re)
(looking-at cobol--type-end-marker-re)
(looking-at cobol--function-end-marker-re)
(looking-at cobol--division-re)
(looking-at cobol--generic-declaration-re))
(cons t (cobol--current-indentation)))
((bobp)
(cons t 0))))))
(defun cobol--phrase-with-not (phrase)
"Return regexp matching line with optional NOT and PHRASE."
(cobol--with-opt-whitespace-line "\\(NOT\\s-+\\)?" phrase))
(defun cobol--at-phrase (phrase)
"Return regexp matching PHRASE with optional AT and NOT."
(cobol--phrase-with-not (concat "\\(AT\\s-+\\)?" phrase)))
(defun cobol--on-phrase (phrase)
"Return regexp matching PHRASE with optional ON and NOT."
(cobol--phrase-with-not (concat "\\(ON\\s-+\\)?" phrase)))
(defun cobol--statements-with-phrase (str)
"Return a list of statements taking the phrase STR."
(cond ((string-match (cobol--with-opt-whitespace-line "WHEN")
str)
'("EVALUATE" "SEARCH"))
((string-match (cobol--at-phrase "END-OF-PAGE") str)
'("WRITE"))
((string-match (cobol--at-phrase "END") str)
;; An AT END clause is added to OPEN in the XML TR.
'("OPEN" "READ" "RETURN" "SEARCH"))
((string-match (cobol--on-phrase "OVERFLOW") str)
'("CALL" "STRING" "UNSTRING"))
((string-match (cobol--on-phrase "EXCEPTION") str)
'("ACCEPT" "CALL" "DISPLAY"))
((string-match (cobol--on-phrase "ESCAPE") str)
'("ACCEPT")) ; MF/ACUCOBOL extension
((string-match (cobol--on-phrase "SIZE\\s-+ERROR") str)
'("ADD" "COMPUTE" "DIVIDE" "MULTIPLY" "SUBTRACT"))
((string-match (cobol--phrase-with-not "INVALID\\s-+KEY") str)
'("DELETE" "READ" "REWRITE" "START"))
(t
(error "Invalid phrase"))))
(defun cobol--scope-terminator-statement (scope-terminator)
"Return the statement contained in SCOPE-TERMINATOR."
(cobol--match-with-leading-whitespace "END-\\(\\w+\\)" scope-terminator)
(match-string 1 scope-terminator))
(defun cobol--first-word (str)
"Return the first word in STR."
(cobol--match-with-leading-whitespace "\\(\\w+\\)" str)
(match-string 1 str))
(defun cobol--go-to-open-statement (statements)
"Go to the last open (unterminated) statement in STATEMENTS."
(let* ((statements-re (regexp-opt statements t))
(valid-statement-re (cobol--with-opt-whitespace-line statements-re))
(valid-scope-terminator-re cobol--scope-terminator-re)
found)
(while (not found)
(forward-line -1)
(cond ((looking-at valid-statement-re)
;; Check the scope-terminator is not on the same line.
(let ((scope-terminator
(concat "END-" (cobol--first-word (thing-at-point 'line)))))
(unless (string-match scope-terminator (thing-at-point 'line))
(setf found t))))
;; Skip past terminated statements
((looking-at valid-scope-terminator-re)
(let ((terminated-statement
(cobol--scope-terminator-statement (thing-at-point 'line))))
(cobol--go-to-open-statement (list terminated-statement))))
;; If no statement is found, stop at beginning of buffer.
((bobp)
(setf found t))))))
(defun cobol--indent-of-open-statement (statements)
"Return the indent of the last open statement in STATEMENTS."
(save-excursion
(cobol--go-to-open-statement statements)
(cobol--current-indentation)))
(defun cobol--indent-of-containing-statement-or-phrase (str)
"Return the indentation of containing statement/phrase in STR."
(let ((phrase (upcase (cobol--first-word str))))
(cond ((or (string-equal phrase "IF")
(string-equal phrase "EVALUATE")
(string-equal phrase "PERFORM"))
(cobol--indent-from-previous))
((string-equal phrase "ELSE")
(cobol--indent-of-open-statement '("IF")))
(t
(cobol--indent (cobol--indent-of-open-statement
(cobol--statements-with-phrase str)))))))
(defun cobol--get-current-division ()
"Return the division containing the point as a symbol."
(cobol--search-back
#'(lambda ()
(cond ((looking-at cobol--division-re)
(string-match cobol--division-re (thing-at-point 'line))
(let ((division (downcase (match-string 1 (thing-at-point 'line)))))
(cons t (intern division))))
((or (looking-at cobol--end-marker-re)
(bobp))
(cons t 'identification))))))
(defun cobol--no-instances-of-after-in-division (instance-re after-re division)
"Actual implementation of `cobol--no-instances-of'."
(and (eq division (cobol--get-current-division))
(cobol--search-back
#'(lambda ()
(cond ((looking-at after-re)
(cons t t))
((or (looking-at instance-re)
(bobp))
(cons t nil)))))))
(defmacro cobol--no-instances-of (&rest clauses)
"CLAUSES must be in the form 're AFTER re-2 IN division' where AFTER and IN
are symbols. Return whether there are no instances of things matched by re
between the point and the previous instance of re-2. Return nil if the point is
not in division or if nothing is found."
(assert (and (eq (length clauses) 5)
(eq (nth 1 clauses) 'after)
(eq (nth 3 clauses) 'in))
nil
"Clauses should be in the form 're AFTER re-2 IN division'.")
`(cobol--no-instances-of-after-in-division ,(first clauses) ,(nth 2 clauses)
,(nth 4 clauses)))
(defun cobol--in-file-control-p ()
"Return whether the point is in the FILE-CONTROL paragraph."
(cobol--no-instances-of cobol--procedure-re
after (cobol--with-opt-whitespace-line "FILE-CONTROL.")
in 'environment))
(defun cobol--no-statements-after (re)
"Return whether there are any statements between the point and the previous
instance of RE."
(cobol--no-instances-of cobol--verb-re
after re
in 'procedure))
(defun cobol--in-proc-div-param-list-p ()
"Return whether the point is in the procedure division header parameter list."
(cobol--no-statements-after cobol--procedure-division-re))
(defun cobol--in-if-eval-when-or-perform-cond-p ()
"Return whether the point is in the condition of an IF, EVALUATE or WHEN or in
the clauses of a non-procedural PERFORM."
(cobol--no-statements-after (cobol--with-opt-whitespace-line
cobol--phrases-with-double-indent-after)))
(defun cobol--indent-of-last-statement ()
"Return the indent of the last statement."
(cobol--search-back-for-indent cobol--verb-re))
(defun cobol--indent-of-clauses ()
"Return the indentation for a clause at the point."
(let ((current-division (cobol--get-current-division)))
(cond ((eq current-division 'identification)
(cobol--indent-from-previous))
((eq current-division 'environment)
(if (cobol--in-file-control-p)
;; Indent clauses of SELECT.
(cobol--indent (cobol--indent-of-last-statement))
(cobol--indent-from-previous)))
((eq current-division 'data)
(- cobol-declaration-clause-indent (cobol--code-start)))
((eq current-division 'procedure)
(cond ((cobol--in-proc-div-param-list-p)
;; Indent procedure division parameter list twice.
(cobol--indent (cobol--search-back-for-indent cobol--procedure-division-re)
2))
((cobol--in-if-eval-when-or-perform-cond-p)
;; Indent after IF/EVALUATE/WHEN/non-procedural PEROFRM twice.
(cobol--indent (cobol--search-back-for-indent
cobol--phrases-with-double-indent-after
:with-whitespace t)
2))
;; Indent once after any other statement.
(t
(cobol--indent (cobol--indent-of-last-statement))))))))
(defun cobol--looking-at-comment-line ()
"Return whether we are looking at a comment line (using `looking-at')."
(or (looking-at cobol--free-form-comment-line-re)
(when (cobol--fixed-format-p)
(looking-at cobol--fixed-form-comment-re))))
(defun cobol--find-indent-of-line ()
"Return what the indent of the current line should be."
(save-excursion
(beginning-of-line)
(cond ((looking-at cobol--scope-terminator-re)
(let ((matching-statement
(cobol--scope-terminator-statement (thing-at-point 'line))))
(cobol--indent-of-open-statement (list matching-statement))))
((looking-at cobol--procedure-re)
(cobol--indent-of-last-div-or-section))
((looking-at cobol--end-marker-re)
(cobol--match-line-with-leading-whitespace
(concat "END" cobol--identifier-re))
(let ((group (match-string 1 (thing-at-point 'line))))
(cobol--indent-of-end-marker-match group)))
((looking-at cobol--division-re)
(cobol--indent-of-last-div))
((looking-at cobol--generic-declaration-re)
(cobol--indent-of-declaration (thing-at-point 'line)))
((looking-at cobol--containing-statement-or-phrase-re)
(cobol--indent-of-containing-statement-or-phrase
(thing-at-point 'line)))
((or (cobol--looking-at-comment-line)
(looking-at cobol--verb-re)
(looking-at cobol--blank-line-re))
(cobol--indent-from-previous))
(t
(cobol--indent-of-clauses)))))
(defun cobol--indent-point-to-col (col)
"Indent the point to COL."
(cond ((< (current-column) col)
(indent-to col))
((> (current-column) col)
(delete-backward-char (- (current-column) col)))))
(defun cobol--set-line-indent (indent)
"Set the indent of the current line to INDENT."
(save-excursion
(let ((line-length (- (line-end-position) (line-beginning-position)))
(end-of-indent (+ (cobol--code-start) indent)))
;; Following lines derived from source of `back-to-indentation'.
(move-to-column (cobol--code-start))
(if (>= line-length (cobol--code-start) (current-column))
(progn
(skip-syntax-forward " " (line-end-position))
(backward-prefix-chars))
(indent-to (cobol--code-start)))
(cobol--indent-point-to-col end-of-indent))))
(defun cobol--indent-point ()
"Indent the point to the next multiple of `cobol-tab-width' (relative to the
start of area A, if fixed-format)."
(cobol--indent-point-to-col
(+ (current-column) (- cobol-tab-width
(% (if (cobol--fixed-format-p)
(1+ (current-column))
(current-column))
cobol-tab-width)))))
(defun cobol-indent-line ()
"Indent current line as COBOL code."
(interactive "*")
(let ((indent (cobol--find-indent-of-line)))
(if (not (eq indent (cobol--current-indentation)))
(progn
(cobol--set-line-indent indent)
;; If in leading whitespace/sequence area, move to first char of code.
(when (< (point) (+ (line-beginning-position) (cobol--code-start) indent))
(skip-syntax-forward " " (line-end-position))
(backward-prefix-chars)))
;; Move to first non-whitespace char
(skip-syntax-forward " " (line-end-position))
(backward-prefix-chars)
;; Indent stuff at point if not the first word.
(when (< (cobol--current-indentation) (- (current-column) (cobol--code-start)))
(cobol--indent-point)))))
;;; Misc
(defvar cobol-tab-width 4 "Width of a tab for `cobol-mode'.")
;;;###autoload
(define-derived-mode cobol-mode prog-mode "COBOL" ()
"COBOL mode is a major mode for handling COBOL files."
:group 'cobol
(set (make-local-variable 'font-lock-defaults) cobol-font-lock-defaults)
(when cobol-tab-width
(set (make-local-variable 'tab-width) cobol-tab-width))
(set (make-local-variable 'indent-tabs-mode) nil)
(set (make-local-variable 'comment-start-skip)
"\\(^.\\{6\\}\\*\\|\\*>\\)\\s-* *")
(set (make-local-variable 'comment-start) "*>")
(set (make-local-variable 'comment-end) "")
(set (make-local-variable 'back-to-indentation) #'cobol-back-to-indentation)
(set (make-local-variable 'syntax-propertize-function)
#'cobol--syntax-propertize-function)
(set (make-local-variable 'cobol-mode-syntax-table) (make-syntax-table))
(modify-syntax-entry ?- "w" cobol-mode-syntax-table)
(modify-syntax-entry ?_ "w" cobol-mode-syntax-table)
(modify-syntax-entry ?* ". 1" cobol-mode-syntax-table)
(modify-syntax-entry ?> "w 2" cobol-mode-syntax-table)
(modify-syntax-entry ?\\ "." cobol-mode-syntax-table)
(modify-syntax-entry ?' "\"" cobol-mode-syntax-table)
(modify-syntax-entry ?\" "\"" cobol-mode-syntax-table)
(modify-syntax-entry ?\n ">" cobol-mode-syntax-table)
(set-syntax-table cobol-mode-syntax-table)
(set (make-local-variable 'column-number-mode) t)
(set (make-local-variable 'indent-line-function) #'cobol-indent-line)
;; Auto complete mode
(set (make-local-variable 'ac-ignore-case) t)
(add-hook 'cobol-mode-hook
#'(lambda () (local-set-key (kbd "RET") #'newline-and-indent)))
;; Some kind of hook call for GNU-correctness
)
(provide 'cobol-mode)
;;; cobol-mode.el ends here
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment