+;;;===========================================================================
+;;; Literal normalization, Hide Actions
+;;;===========================================================================
+
+(defun antlr-downcase-literals (&optional transform)
+ "Convert all literals in buffer to lower case.
+If non-nil, TRANSFORM is used on literals instead of `downcase-region'."
+ (interactive)
+ (or transform (setq transform 'downcase-region))
+ (let ((literals 0))
+ (save-excursion
+ (goto-char (point-min))
+ (antlr-with-syntax-table antlr-action-syntax-table
+ (antlr-invalidate-context-cache)
+ (while (antlr-re-search-forward "\"\\(\\sw\\(\\sw\\|-\\)*\\)\"" nil)
+ (funcall transform (match-beginning 0) (match-end 0))
+ (incf literals))))
+ (message "Transformed %d literals" literals)))
+
+(defun antlr-upcase-literals ()
+ "Convert all literals in buffer to upper case."
+ (interactive)
+ (antlr-downcase-literals 'upcase-region))
+
+(defun antlr-hide-actions (arg &optional silent)
+ "Hide or unhide all actions in buffer.
+Hide all actions including arguments in brackets if ARG is 1 or if
+called interactively without prefix argument. Hide all actions
+excluding arguments in brackets if ARG is 2 or higher. Unhide all
+actions if ARG is 0 or negative. See `antlr-action-visibility'.
+
+Display a message unless optional argument SILENT is non-nil."
+ (interactive "p")
+ (save-buffer-state-x
+ (if (> arg 0)
+ (let ((regexp (if (= arg 1) "[]}]" "}"))
+ (diff (and antlr-action-visibility
+ (+ (max antlr-action-visibility 0) 2))))
+ (antlr-hide-actions 0 t)
+ (save-excursion
+ (goto-char (point-min))
+ (antlr-with-syntax-table antlr-action-syntax-table
+ (antlr-invalidate-context-cache)
+ (while (antlr-re-search-forward regexp nil)
+ (let ((beg (ignore-errors-x (scan-sexps (point) -1))))
+ (when beg
+ (if diff ; braces are visible
+ (if (> (point) (+ beg diff))
+ (add-text-properties (1+ beg) (1- (point))
+ '(invisible t intangible t)))
+ ;; if actions is on line(s) of its own, hide WS
+ (and (looking-at "[ \t]*$")
+ (save-excursion
+ (goto-char beg)
+ (skip-chars-backward " \t")
+ (and (bolp) (setq beg (point))))
+ (beginning-of-line 2)) ; beginning of next line
+ (add-text-properties beg (point)
+ '(invisible t intangible t))))))))
+ (or silent
+ (message "Hide all actions (%s arguments)...done"
+ (if (= arg 1) "including" "excluding"))))
+ (remove-text-properties (point-min) (point-max)
+ '(invisible nil intangible nil))
+ (or silent
+ (message "Unhide all actions (including arguments)...done")))))
+
+
+;;;===========================================================================
+;;; Insert option: command
+;;;===========================================================================
+
+(defun antlr-insert-option (level option &optional location)
+ "Insert file/grammar/rule/subrule option near point.
+LEVEL determines option kind to insert: 1=file, 2=grammar, 3=rule,
+4=subrule. OPTION is a string with the name of the option to insert.
+LOCATION can be specified for not calling `antlr-option-kind' twice.
+
+Inserting an option with this command works as follows:
+
+ 1. When called interactively, LEVEL is determined by the prefix
+ argument or automatically deduced without prefix argument.
+ 2. Signal an error if no option of that level could be inserted, e.g.,
+ if the buffer is read-only, the option area is outside the visible
+ part of the buffer or a subrule/rule option should be inserted with
+ point outside a subrule/rule.
+ 3. When called interactively, OPTION is read from the minibuffer with
+ completion over the known options of the given LEVEL.
+ 4. Ask user for confirmation if the given OPTION does not seem to be a
+ valid option to insert into the current file.
+ 5. Find a correct position to insert the option.
+ 6. Depending on the option, insert it the following way \(inserting an
+ option also means inserting the option section if necessary\):
+ - Insert the option and let user insert the value at point.
+ - Read a value (with completion) from the minibuffer, using a
+ previous value as initial contents, and insert option with value.
+ 7. Final action depending on the option. For example, set the language
+ according to a newly inserted language option.
+
+The name of all options with a specification for their values are stored
+in `antlr-options-alists'. The used specification also depends on the
+value of `antlr-tool-version', i.e., step 4 will warn you if you use an
+option that has been introduced in newer version of ANTLR, and step 5
+will offer completion using version-correct values.
+
+If the option already exists inside the visible part of the buffer, this
+command can be used to change the value of that option. Otherwise, find
+a correct position where the option can be inserted near point.
+
+The search for a correct position is as follows:
+
+ * If search is within an area where options can be inserted, use the
+ position of point. Inside the options section and if point is in
+ the middle of a option definition, skip the rest of it.
+ * If an options section already exists, insert the options at the end.
+ If only the beginning of the area is visible, insert at the
+ beginning.
+ * Otherwise, find the position where an options section can be
+ inserted and insert a new section before any comments. If the
+ position before the comments is not visible, insert the new section
+ after the comments.
+
+This function also inserts \"options {...}\" and the \":\" if necessary,
+see `antlr-options-auto-colon'. See also `antlr-options-assign-string'.
+
+This command might also set the mark like \\[set-mark-command] does, see
+`antlr-options-push-mark'."
+ (interactive (antlr-insert-option-interactive current-prefix-arg))
+ (barf-if-buffer-read-only)
+ (or location (setq location (cdr (antlr-option-kind level))))
+ (cond ((null level)
+ (error "Cannot deduce what kind of option to insert"))
+ ((atom location)
+ (error "Cannot insert any %s options around here"
+ (elt antlr-options-headings (1- level)))))
+ (let ((area (car location))
+ (place (cdr location)))
+ (cond ((null place) ; invisible
+ (error (if area
+ "Invisible %s options, use %s to make them visible"
+ "Invisible area for %s options, use %s to make it visible")
+ (elt antlr-options-headings (1- level))
+ (substitute-command-keys "\\[widen]")))
+ ((null area) ; without option part
+ (antlr-insert-option-do level option nil
+ (null (cdr place))
+ (car place)))
+ ((save-excursion ; with option part, option visible
+ (goto-char (max (point-min) (car area)))
+ (re-search-forward (concat "\\(^\\|;\\)[ \t]*\\(\\<"
+ (regexp-quote option)
+ "\\>\\)[ \t\n]*\\(\\(=[ \t]?\\)[ \t]*\\(\\(\\sw\\|\\s_\\)+\\|\"\\([^\n\"\\]\\|[\\][^\n]\\)*\"\\)?\\)?")
+ ;; 2=name, 3=4+5, 4="=", 5=value
+ (min (point-max) (cdr area))
+ t))
+ (antlr-insert-option-do level option
+ (cons (or (match-beginning 5)
+ (match-beginning 3))
+ (match-end 5))
+ (and (null (cdr place)) area)
+ (or (match-beginning 5)
+ (match-end 4)
+ (match-end 2))))
+ (t ; with option part, option not yet
+ (antlr-insert-option-do level option t
+ (and (null (cdr place)) area)
+ (car place))))))
+
+(defun antlr-insert-option-interactive (arg)
+ "Interactive specification for `antlr-insert-option'.
+Return \(LEVEL OPTION LOCATION)."
+ (barf-if-buffer-read-only)
+ (if arg (setq arg (prefix-numeric-value arg)))
+ (unless (memq arg '(nil 1 2 3 4))
+ (error "Valid prefix args: no=auto, 1=file, 2=grammar, 3=rule, 4=subrule"))
+ (let* ((kind (antlr-option-kind arg))
+ (level (car kind)))
+ (if (atom (cdr kind))
+ (list level nil (cdr kind))
+ (let* ((table (elt antlr-options-alists (1- level)))
+ (completion-ignore-case t) ;dynamic
+ (input (completing-read (format "Insert %s option: "
+ (elt antlr-options-headings
+ (1- level)))
+ table)))
+ (list level input (cdr kind))))))
+
+(defun antlr-options-menu-filter (level menu-items)
+ "Return items for options submenu of level LEVEL."
+ ;; checkdoc-params: (menu-items)
+ (let ((active (if buffer-read-only
+ nil
+ (consp (cdr-safe (cdr (antlr-option-kind level)))))))
+ (mapcar (lambda (option)
+ (vector option
+ (list 'antlr-insert-option level option)
+ :active active))
+ (sort (mapcar 'car (elt antlr-options-alists (1- level)))
+ 'string-lessp))))
+
+
+;;;===========================================================================
+;;; Insert option: determine section-kind
+;;;===========================================================================
+
+(defun antlr-option-kind (requested)
+ "Return level and location for option to insert near point.
+Call function `antlr-option-level' with argument REQUESTED. If the
+result is nil, return \(REQUESTED \. error). If the result has the
+non-nil value LEVEL, return \(LEVEL \. LOCATION) where LOCATION looks
+like \(AREA \. PLACE), see `antlr-option-location'."
+ (save-excursion
+ (save-restriction
+ (let ((min0 (point-min)) ; before `widen'!
+ (max0 (point-max))
+ (orig (point))
+ (level (antlr-option-level requested)) ; calls `widen'!
+ pos)
+ (cond ((null level)
+ (setq level requested))
+ ((eq level 1) ; file options
+ (goto-char (point-min))
+ (setq pos (antlr-skip-file-prelude 'header-only)))
+ ((not (eq level 3)) ; grammar or subrule options
+ (setq pos (point))
+ (antlr-c-forward-sws))
+ ((looking-at "^\\(private[ \t\n]\\|public[ \t\n]\\|protected[ \t\n]\\)?[ \t\n]*\\(\\(\\sw\\|\\s_\\)+\\)[ \t\n]*\\(!\\)?[ \t\n]*\\(\\[\\)?")
+ ;; rule options, with complete rule header
+ (goto-char (or (match-end 4) (match-end 3)))
+ (setq pos (antlr-skip-sexps (if (match-end 5) 1 0)))
+ (when (looking-at "returns[ \t\n]*\\[")
+ (goto-char (1- (match-end 0)))
+ (setq pos (antlr-skip-sexps 1)))))
+ (cons level
+ (cond ((null pos) 'error)
+ ((looking-at "options[ \t\n]*{")
+ (goto-char (match-end 0))
+ (setq pos (ignore-errors-x (scan-lists (point) 1 1)))
+ (antlr-option-location orig min0 max0
+ (point)
+ (if pos (1- pos) (point-max))
+ t))
+ (t
+ (antlr-option-location orig min0 max0
+ pos (point)
+ nil))))))))
+
+(defun antlr-option-level (requested)
+ "Return level for option to insert near point.
+Remove any restrictions from current buffer and return level for the
+option to insert near point, i.e., 1, 2, 3, 4, or nil if no such option
+can be inserted. If REQUESTED is non-nil, it is the only possible value
+to return except nil. If REQUESTED is nil, return level for the nearest
+option kind, i.e., the highest number possible.
+
+If the result is 2, point is at the beginning of the class after the
+class definition. If the result is 3 or 4, point is at the beginning of
+the rule/subrule after the init action. Otherwise, the point position
+is undefined."
+ (widen)
+ (if (eq requested 1)
+ 1
+ (antlr-with-syntax-table antlr-action-syntax-table
+ (antlr-invalidate-context-cache)
+ (let* ((orig (point))
+ (outsidep (antlr-outside-rule-p))
+ bor depth)
+ (if (eq (char-after) ?\{) (antlr-skip-sexps 1))
+ (setq bor (point)) ; beginning of rule (after init action)
+ (cond ((eq requested 2) ; grammar options required?
+ (let (boc) ; beginning of class
+ (goto-char (point-min))
+ (while (and (<= (point) bor)
+ (antlr-re-search-forward antlr-class-header-regexp
+ nil))
+ (if (<= (match-beginning 0) bor)
+ (setq boc (match-end 0))))
+ (when boc
+ (goto-char boc)
+ 2)))
+ ((save-excursion ; in region of file options?
+ (goto-char (point-min))
+ (antlr-skip-file-prelude t) ; ws/comment after: OK
+ (< orig (point)))
+ (and (null requested) 1))
+ (outsidep ; outside rule not OK
+ nil)
+ ((looking-at antlr-class-header-regexp) ; rule = class def?
+ (goto-char (match-end 0))
+ (and (null requested) 2))
+ ((eq requested 3) ; rule options required?
+ (goto-char bor)
+ 3)
+ ((setq depth (antlr-syntactic-grammar-depth orig bor))
+ (if (> depth 0) ; move out of actions
+ (goto-char (scan-lists (point) -1 depth)))
+ (set-syntax-table antlr-mode-syntax-table)
+ (antlr-invalidate-context-cache)
+ (if (eq (antlr-syntactic-context) 0) ; not in subrule?
+ (unless (eq requested 4)
+ (goto-char bor)
+ 3)
+ (goto-char (1+ (scan-lists (point) -1 1)))
+ 4)))))))
+
+(defun antlr-option-location (orig min-vis max-vis min-area max-area withp)
+ "Return location for the options area.
+ORIG is the original position of `point', MIN-VIS is `point-min' and
+MAX-VIS is `point-max'. If WITHP is non-nil, there exists an option
+specification and it starts after the brace at MIN-AREA and stops at
+MAX-AREA. If WITHP is nil, there is no area and the region where it
+could be inserted starts at MIN-AREA and stops at MAX-AREA.
+
+The result has the form (AREA . PLACE). AREA is (MIN-AREA . MAX-AREA)
+if WITHP is non-nil, and nil otherwise. PLACE is nil if the area is
+invisible, (ORIG) if ORIG is inside the area, (MIN-AREA . beginning) for
+a visible start position and (MAX-AREA . end) for a visible end position
+where the beginning is preferred if WITHP is nil and the end if WITHP is
+non-nil."
+ (cons (and withp (cons min-area max-area))
+ (cond ((and (<= min-area orig) (<= orig max-area)
+ (save-excursion
+ (goto-char orig)
+ (not (memq (antlr-syntactic-context)
+ '(comment block-comment)))))
+ ;; point in options area and not in comment
+ (list orig))
+ ((and (null withp) (<= min-vis min-area) (<= min-area max-vis))
+ ;; use start of options area (only if not `withp')
+ (cons min-area 'beginning))
+ ((and (<= min-vis max-area) (<= max-area max-vis))
+ ;; use end of options area
+ (cons max-area 'end))
+ ((and withp (<= min-vis min-area) (<= min-area max-vis))
+ ;; use start of options area (only if `withp')
+ (cons min-area 'beginning)))))
+
+(defun antlr-syntactic-grammar-depth (pos beg)
+ "Return syntactic context depth at POS.
+Move to POS and from there on to the beginning of the string or comment
+if POS is inside such a construct. Then, return the syntactic context
+depth at point if the point position is smaller than BEG.
+WARNING: this may alter `match-data'."
+ (goto-char pos)
+ (let ((context (or (antlr-syntactic-context) 0)))
+ (while (and context (not (integerp context)))
+ (cond ((eq context 'string)
+ (setq context
+ (and (search-backward "\"" nil t)
+ (>= (point) beg)
+ (or (antlr-syntactic-context) 0))))
+ ((memq context '(comment block-comment))
+ (setq context
+ (and (re-search-backward "/[/*]" nil t)
+ (>= (point) beg)
+ (or (antlr-syntactic-context) 0))))))
+ context))
+
+
+;;;===========================================================================
+;;; Insert options: do the insertion
+;;;===========================================================================
+
+(defun antlr-insert-option-do (level option old area pos)
+ "Insert option into buffer at position POS.
+Insert option of level LEVEL and name OPTION. If OLD is non-nil, an
+options area is already exists. If OLD looks like \(BEG \. END), the
+option already exists. Then, BEG is the start position of the option
+value, the position of the `=' or nil, and END is the end position of
+the option value or nil.
+
+If the original point position was outside an options area, AREA is nil.
+Otherwise, and if an option specification already exists, AREA is a cons
+cell where the two values determine the area inside the braces."
+ (let* ((spec (cdr (assoc option (elt antlr-options-alists (1- level)))))
+ (value (antlr-option-spec level option (cdr spec) (consp old))))
+ (if (fboundp (car spec)) (funcall (car spec) 'before-input option))
+ ;; set mark (unless point was inside options area before)
+ (if (cond (area (eq antlr-options-push-mark t))
+ ((numberp antlr-options-push-mark)
+ (> (count-lines (min (point) pos) (max (point) pos))
+ antlr-options-push-mark))
+ (antlr-options-push-mark))
+ (push-mark))
+ ;; read option value -----------------------------------------------------
+ (goto-char pos)
+ (if (null value)
+ ;; no option specification found
+ (if (y-or-n-p (format "Insert unknown %s option %s? "
+ (elt antlr-options-headings (1- level))
+ option))
+ (message "Insert value for %s option %s"
+ (elt antlr-options-headings (1- level))
+ option)
+ (error "Didn't insert unknown %s option %s"
+ (elt antlr-options-headings (1- level))
+ option))
+ ;; option specification found
+ (setq value (cdr value))
+ (if (car value)
+ (let ((initial (and (consp old) (cdr old)
+ (buffer-substring (car old) (cdr old)))))
+ (setq value (apply (car value)
+ (and initial
+ (if (eq (aref initial 0) ?\")
+ (read initial)
+ initial))
+ (cdr value))))
+ (message (cadr value))
+ (setq value nil)))
+ ;; insert value ----------------------------------------------------------
+ (if (consp old)
+ (antlr-insert-option-existing old value)
+ (if (consp area)
+ ;; Move outside string/comment if point is inside option spec
+ (antlr-syntactic-grammar-depth (point) (car area)))
+ (antlr-insert-option-space area old)
+ (or old (antlr-insert-option-area level))
+ (insert option " = ;")
+ (backward-char)
+ (if value (insert value)))
+ ;; final -----------------------------------------------------------------
+ (if (fboundp (car spec)) (funcall (car spec) 'after-insertion option))))
+
+(defun antlr-option-spec (level option specs existsp)
+ "Return version correct option value specification.
+Return specification for option OPTION of kind level LEVEL. SPECS
+should correspond to the VALUE-SPEC... in `antlr-option-alists'.
+EXISTSP determines whether the option already exists."
+ (let (value)
+ (while (and specs (>= antlr-tool-version (caar specs)))
+ (setq value (pop specs)))
+ (cond (value) ; found correct spec
+ ((null specs) nil) ; didn't find any specs
+ (existsp (car specs)) ; wrong version, but already present
+ ((y-or-n-p (format "Insert v%s %s option %s in v%s? "
+ (antlr-version-string (caar specs))
+ (elt antlr-options-headings (1- level))
+ option
+ (antlr-version-string antlr-tool-version)))
+ (car specs))
+ (t
+ (error "Didn't insert v%s %s option %s in v%s"
+ (antlr-version-string (caar specs))
+ (elt antlr-options-headings (1- level))
+ option
+ (antlr-version-string antlr-tool-version))))))
+
+(defun antlr-version-string (version)
+ "Format the Antlr version number VERSION, see `antlr-tool-version'."
+ (let ((version100 (/ version 100)))
+ (format "%d.%d.%d"
+ (/ version100 100) (mod version100 100) (mod version 100))))
+
+
+;;;===========================================================================
+;;; Insert options: the details (used by `antlr-insert-option-do')
+;;;===========================================================================
+
+(defun antlr-insert-option-existing (old value)
+ "Insert option value VALUE at point for existing option.
+For OLD, see `antlr-insert-option-do'."
+ ;; no = => insert =
+ (unless (car old) (insert antlr-options-assign-string))
+ ;; with user input => insert if necessary
+ (when value
+ (if (cdr old) ; with value
+ (if (string-equal value (buffer-substring (car old) (cdr old)))
+ (goto-char (cdr old))
+ (delete-region (car old) (cdr old))
+ (insert value))
+ (insert value)))
+ (unless (looking-at "\\([^\n=;{}/'\"]\\|'\\([^\n'\\]\\|\\\\.\\)*'\\|\"\\([^\n\"\\]\\|\\\\.\\)*\"\\)*;")
+ ;; stuff (no =, {, } or /) at point is not followed by ";"
+ (insert ";")
+ (backward-char)))
+
+(defun antlr-insert-option-space (area old)
+ "Find appropriate place to insert option, insert newlines/spaces.
+For AREA and OLD, see `antlr-insert-option-do'."
+ (let ((orig (point))
+ (open t))
+ (skip-chars-backward " \t")
+ (unless (bolp)
+ (let ((before (char-after (1- (point)))))
+ (goto-char orig)
+ (and old ; with existing options area
+ (consp area) ; if point inside existing area
+ (not (eq before ?\;)) ; if not at beginning of option
+ ; => skip to end of option
+ (if (and (search-forward ";" (cdr area) t)
+ (let ((context (antlr-syntactic-context)))
+ (or (null context) (numberp context))))
+ (setq orig (point))
+ (goto-char orig)))
+ (skip-chars-forward " \t")
+
+ (if (looking-at "$\\|//")
+ ;; just comment after point => skip (+ lines w/ same col comment)
+ (let ((same (if (> (match-end 0) (match-beginning 0))
+ (current-column))))
+ (beginning-of-line 2)
+ (or (bolp) (insert "\n"))
+ (when (and same (null area)) ; or (consp area)?
+ (while (and (looking-at "[ \t]*\\(//\\)")
+ (goto-char (match-beginning 1))
+ (= (current-column) same))
+ (beginning-of-line 2)
+ (or (bolp) (insert "\n")))))
+ (goto-char orig)
+ (if (null old)
+ (progn (insert "\n") (antlr-indent-line))
+ (unless (eq (char-after (1- (point))) ?\ )
+ (insert " "))
+ (unless (eq (char-after (point)) ?\ )
+ (insert " ")
+ (backward-char))
+ (setq open nil)))))
+ (when open
+ (beginning-of-line 1)
+ (insert "\n")
+ (backward-char)
+ (antlr-indent-line))))
+
+(defun antlr-insert-option-area (level)
+ "Insert new options area for options of level LEVEL.
+Used by `antlr-insert-option-do'."
+ (insert "options {\n\n}")
+ (when (and antlr-options-auto-colon
+ (memq level '(3 4))
+ (save-excursion
+ (antlr-c-forward-sws)
+ (if (eq (char-after (point)) ?\{) (antlr-skip-sexps 1))
+ (not (eq (char-after (point)) ?\:))))
+ (insert "\n:")
+ (antlr-indent-line)
+ (end-of-line 0))
+ (backward-char 1)
+ (antlr-indent-line)
+ (beginning-of-line 0)
+ (antlr-indent-line))
+
+
+;;;===========================================================================
+;;; Insert options: in `antlr-options-alists'
+;;;===========================================================================
+
+(defun antlr-read-value (initial-contents prompt
+ &optional as-string table table-x)
+ "Read a string from the minibuffer, possibly with completion.
+If INITIAL-CONTENTS is non-nil, insert it in the minibuffer initially.
+PROMPT is a string to prompt with, normally it ends in a colon and a
+space. If AS-STRING is t or is a member \(comparison done with `eq') of
+`antlr-options-style', return printed representation of the user input,
+otherwise return the user input directly.
+
+If TABLE or TABLE-X is non-nil, read with completion. The completion
+table is the resulting alist of TABLE-X concatenated with TABLE where
+TABLE can also be a function evaluation to an alist.
+
+Used inside `antlr-options-alists'."
+ (let* ((completion-ignore-case t) ; dynamic
+ (table0 (and (or table table-x)
+ (append table-x
+ (if (functionp table) (funcall table) table))))
+ (input (if table0
+ (completing-read prompt table0 nil nil initial-contents)
+ (read-from-minibuffer prompt initial-contents))))
+ (if (and as-string
+ (or (eq as-string t)
+ (cdr (assq as-string antlr-options-style))))
+ (format "%S" input)
+ input)))
+
+(defun antlr-read-boolean (initial-contents prompt &optional table)
+ "Read a boolean value from the minibuffer, with completion.
+If INITIAL-CONTENTS is non-nil, insert it in the minibuffer initially.
+PROMPT is a string to prompt with, normally it ends in a question mark
+and a space. \"(true or false) \" is appended if TABLE is nil.
+
+Read with completion over \"true\", \"false\" and the keys in TABLE, see
+also `antlr-read-value'.
+
+Used inside `antlr-options-alists'."
+ (antlr-read-value initial-contents
+ (if table prompt (concat prompt "(true or false) "))
+ nil
+ table '(("false") ("true"))))
+
+(defun antlr-language-option-extra (phase &rest dummies)
+;; checkdoc-params: (dummies)
+ "Change language according to the new value of the \"language\" option.
+Call `antlr-mode' if the new language would be different from the value
+of `antlr-language', keeping the value of variable `font-lock-mode'.
+
+Called in PHASE `after-insertion', see `antlr-options-alists'."
+ (when (eq phase 'after-insertion)
+ (let ((new-language (antlr-language-option t)))
+ (or (null new-language)
+ (eq new-language antlr-language)
+ (let ((font-lock (and (boundp 'font-lock-mode) font-lock-mode)))
+ (if font-lock (font-lock-mode 0))
+ (antlr-mode)
+ (and font-lock (null font-lock-mode) (font-lock-mode 1)))))))
+
+(defun antlr-c++-mode-extra (phase option &rest dummies)
+;; checkdoc-params: (option dummies)
+ "Warn if C++ option is used with the wrong language.
+Ask user \(\"y or n\"), if a C++ only option is going to be inserted but
+`antlr-language' has not the value `c++-mode'.
+
+Called in PHASE `before-input', see `antlr-options-alists'."
+ (and (eq phase 'before-input)
+ (not (eq antlr-language 'c++-mode))
+ (not (y-or-n-p (format "Insert C++ %s option? " option)))
+ (error "Didn't insert C++ %s option with language %s"
+ option (cadr (assq antlr-language antlr-language-alist)))))
+
+
+;;;===========================================================================
+;;; Compute dependencies
+;;;===========================================================================
+
+(defun antlr-file-dependencies ()
+ "Return dependencies for grammar in current buffer.
+The result looks like \(FILE \(CLASSES \. SUPERS) VOCABS \. LANGUAGE)
+ where CLASSES = ((CLASS . CLASS-EVOCAB) ...),
+ SUPERS = ((SUPER . USE-EVOCAB-P) ...), and
+ VOCABS = ((EVOCAB ...) . (IVOCAB ...))
+
+FILE is the current buffer's file-name without directory part and
+LANGUAGE is the value of `antlr-language' in the current buffer. Each
+EVOCAB is an export vocabulary and each IVOCAB is an import vocabulary.
+
+Each CLASS is a grammar class with its export vocabulary CLASS-EVOCAB.
+Each SUPER is a super-grammar class where USE-EVOCAB-P indicates whether
+its export vocabulary is used as an import vocabulary."
+ (unless buffer-file-name
+ (error "Grammar buffer does not visit a file"))
+ (let (classes export-vocabs import-vocabs superclasses default-vocab)
+ (antlr-with-syntax-table antlr-action-syntax-table
+ (goto-char (point-min))
+ (while (antlr-re-search-forward antlr-class-header-regexp nil)
+ ;; parse class definition --------------------------------------------
+ (let* ((class (match-string 2))
+ (sclass (match-string 4))
+ ;; export vocab defaults to class name (first grammar in file)
+ ;; or to the export vocab of the first grammar in file:
+ (evocab (or default-vocab class))
+ (ivocab nil))
+ (goto-char (match-end 0))
+ (antlr-c-forward-sws)
+ (while (looking-at "options\\>\\|\\(tokens\\)\\>")
+ (if (match-beginning 1)
+ (antlr-skip-sexps 2)
+ (goto-char (match-end 0))
+ (antlr-c-forward-sws)
+ ;; parse grammar option sections -------------------------------
+ (when (eq (char-after (point)) ?\{)
+ (let* ((beg (1+ (point)))
+ (end (1- (antlr-skip-sexps 1)))
+ (cont (point)))
+ (goto-char beg)
+ (if (re-search-forward "\\<exportVocab[ \t]*=[ \t]*\\([A-Za-z\300-\326\330-\337]\\sw*\\)" end t)
+ (setq evocab (match-string 1)))
+ (goto-char beg)
+ (if (re-search-forward "\\<importVocab[ \t]*=[ \t]*\\([A-Za-z\300-\326\330-\337]\\sw*\\)" end t)
+ (setq ivocab (match-string 1)))
+ (goto-char cont)))))
+ (unless (member sclass '("Parser" "Lexer" "TreeParser"))
+ (let ((super (assoc sclass superclasses)))
+ (if super
+ (or ivocab (setcdr super t))
+ (push (cons sclass (null ivocab)) superclasses))))
+ ;; remember class with export vocabulary:
+ (push (cons class evocab) classes)
+ ;; default export vocab is export vocab of first grammar in file:
+ (or default-vocab (setq default-vocab evocab))
+ (or (member evocab export-vocabs) (push evocab export-vocabs))
+ (or (null ivocab)
+ (member ivocab import-vocabs) (push ivocab import-vocabs)))))
+ (if classes
+ (list* (file-name-nondirectory buffer-file-name)
+ (cons (nreverse classes) (nreverse superclasses))
+ (cons (nreverse export-vocabs) (nreverse import-vocabs))
+ antlr-language))))
+
+(defun antlr-directory-dependencies (dirname)
+ "Return dependencies for all grammar files in directory DIRNAME.
+The result looks like \((CLASS-SPEC ...) \. \(FILE-DEP ...))
+ where CLASS-SPEC = (CLASS (FILE \. EVOCAB) ...).
+
+FILE-DEP are the dependencies for each grammar file in DIRNAME, see
+`antlr-file-dependencies'. For each grammar class CLASS, FILE is a
+grammar file in which CLASS is defined and EVOCAB is the name of the
+export vocabulary specified in that file."
+ (let ((grammar (directory-files dirname t "\\.g\\'")))
+ (when grammar
+ (let ((temp-buffer (get-buffer-create
+ (generate-new-buffer-name " *temp*")))
+ (antlr-imenu-name nil) ; dynamic-let: no imenu
+ (expanded-regexp (concat (format (regexp-quote
+ (cadr antlr-special-file-formats))
+ ".+")
+ "\\'"))
+ classes dependencies)
+ (unwind-protect
+ (save-excursion
+ (set-buffer temp-buffer)
+ (widen) ; just in case...
+ (dolist (file grammar)
+ (when (and (file-regular-p file)
+ (null (string-match expanded-regexp file)))
+ (insert-file-contents file t nil nil t)
+ (normal-mode t) ; necessary for major-mode, syntax
+ ; table and `antlr-language'
+ (when (eq major-mode 'antlr-mode)
+ (let* ((file-deps (antlr-file-dependencies))
+ (file (car file-deps)))
+ (when file-deps
+ (dolist (class-def (caadr file-deps))
+ (let ((file-evocab (cons file (cdr class-def)))
+ (class-spec (assoc (car class-def) classes)))
+ (if class-spec
+ (nconc (cdr class-spec) (list file-evocab))
+ (push (list (car class-def) file-evocab)
+ classes))))
+ (push file-deps dependencies)))))))
+ (kill-buffer temp-buffer))
+ (cons (nreverse classes) (nreverse dependencies))))))
+
+
+;;;===========================================================================
+;;; Compilation: run ANTLR tool
+;;;===========================================================================
+
+(defun antlr-superclasses-glibs (supers classes)
+ "Compute the grammar lib option for the super grammars SUPERS.
+Look in CLASSES for the right grammar lib files for SUPERS. SUPERS is
+part SUPER in the result of `antlr-file-dependencies'. CLASSES is the
+part \(CLASS-SPEC ...) in the result of `antlr-directory-dependencies'.
+
+The result looks like \(OPTION WITH-UNKNOWN GLIB ...). OPTION is the
+complete \"-glib\" option. WITH-UNKNOWN is t if there is none or more
+than one grammar file for at least one super grammar.
+
+Each GLIB looks like \(GRAMMAR-FILE \. EVOCAB). GRAMMAR-FILE is a file
+in which a super-grammar is defined. EVOCAB is the value of the export
+vocabulary of the super-grammar or nil if it is not needed."
+ ;; If the superclass is defined in the same file, that file will be included
+ ;; with -glib again. This will lead to a redefinition. But defining a
+ ;; analyzer of the same class twice in a file will lead to an error anyway...
+ (let (glibs unknown)
+ (while supers
+ (let* ((super (pop supers))
+ (sup-files (cdr (assoc (car super) classes)))
+ (file (and sup-files (null (cdr sup-files)) (car sup-files))))
+ (or file (setq unknown t)) ; not exactly one file
+ (push (cons (or (car file)
+ (format (car antlr-unknown-file-formats)
+ (car super)))
+ (and (cdr super)
+ (or (cdr file)
+ (format (cadr antlr-unknown-file-formats)
+ (car super)))))
+ glibs)))
+ (cons (if glibs (concat " -glib " (mapconcat 'car glibs ";")) "")
+ (cons unknown glibs))))
+
+(defun antlr-run-tool (command file &optional saved)
+ "Run Antlr took COMMAND on grammar FILE.
+When called interactively, COMMAND is read from the minibuffer and
+defaults to `antlr-tool-command' with a computed \"-glib\" option if
+necessary.
+
+Save all buffers first unless optional value SAVED is non-nil. When
+called interactively, the buffers are always saved, see also variable
+`antlr-ask-about-save'."
+ (interactive (antlr-run-tool-interactive))
+ (or saved (save-some-buffers (not antlr-ask-about-save)))
+ (let ((default-directory (file-name-directory file)))
+ (compilation-start (concat command " " (file-name-nondirectory file))
+ nil #'(lambda (mode-name) "*Antlr-Run*"))))
+
+(defun antlr-run-tool-interactive ()
+ ;; code in `interactive' is not compiled
+ "Interactive specification for `antlr-run-tool'.
+Use prefix argument ARG to return \(COMMAND FILE SAVED)."
+ (let* ((supers (cdadr (save-excursion
+ (save-restriction
+ (widen)
+ (antlr-file-dependencies)))))
+ (glibs ""))
+ (when supers
+ (save-some-buffers (not antlr-ask-about-save) nil)
+ (setq glibs (car (antlr-superclasses-glibs
+ supers
+ (car (antlr-directory-dependencies
+ (antlr-default-directory)))))))
+ (list (antlr-read-shell-command "Run Antlr on current file with: "
+ (concat antlr-tool-command glibs " "))
+ buffer-file-name
+ supers)))
+
+
+;;;===========================================================================
+;;; Makefile creation
+;;;===========================================================================
+
+(defun antlr-makefile-insert-variable (number pre post)
+ "Insert Makefile variable numbered NUMBER according to specification.
+Also insert strings PRE and POST before and after the variable."
+ (let ((spec (cadr antlr-makefile-specification)))
+ (when spec
+ (insert pre
+ (if number (format (cadr spec) number) (car spec))
+ post))))
+
+(defun antlr-insert-makefile-rules (&optional in-makefile)
+ "Insert Makefile rules in the current buffer at point.
+IN-MAKEFILE is non-nil, if the current buffer is the Makefile. See
+command `antlr-show-makefile-rules' for detail."
+ (let* ((dirname (antlr-default-directory))
+ (deps0 (antlr-directory-dependencies dirname))
+ (classes (car deps0)) ; CLASS -> (FILE . EVOCAB) ...
+ (deps (cdr deps0)) ; FILE -> (c . s) (ev . iv) . LANGUAGE
+ (with-error nil)
+ (gen-sep (or (caddr (cadr antlr-makefile-specification)) " "))
+ (n (and (cdr deps) (cadr antlr-makefile-specification) 0)))
+ (or in-makefile (set-buffer standard-output))
+ (dolist (dep deps)
+ (let ((supers (cdadr dep))
+ (lang (cdr (assoc (cdddr dep) antlr-file-formats-alist))))
+ (if n (incf n))
+ (antlr-makefile-insert-variable n "" " =")
+ (if supers
+ (insert " "
+ (format (cadr antlr-special-file-formats)
+ (file-name-sans-extension (car dep)))))
+ (dolist (class-def (caadr dep))
+ (let ((sep gen-sep))
+ (dolist (class-file (cadr lang))
+ (insert sep (format class-file (car class-def)))
+ (setq sep " "))))
+ (dolist (evocab (caaddr dep))
+ (let ((sep gen-sep))
+ (dolist (vocab-file (cons (car antlr-special-file-formats)
+ (car lang)))
+ (insert sep (format vocab-file evocab))
+ (setq sep " "))))
+ (antlr-makefile-insert-variable n "\n$(" ")")
+ (insert ": " (car dep))
+ (dolist (ivocab (cdaddr dep))
+ (insert " " (format (car antlr-special-file-formats) ivocab)))
+ (let ((glibs (antlr-superclasses-glibs supers classes)))
+ (if (cadr glibs) (setq with-error t))
+ (dolist (super (cddr glibs))
+ (insert " " (car super))
+ (if (cdr super)
+ (insert " " (format (car antlr-special-file-formats)
+ (cdr super)))))
+ (insert "\n\t"
+ (caddr antlr-makefile-specification)
+ (car glibs)
+ " $<\n"
+ (car antlr-makefile-specification)))))
+ (if n
+ (let ((i 0))
+ (antlr-makefile-insert-variable nil "" " =")
+ (while (<= (incf i) n)
+ (antlr-makefile-insert-variable i " $(" ")"))
+ (insert "\n" (car antlr-makefile-specification))))
+ (if (string-equal (car antlr-makefile-specification) "\n")
+ (backward-delete-char 1))
+ (when with-error
+ (goto-char (point-min))
+ (insert antlr-help-unknown-file-text))
+ (unless in-makefile
+ (copy-region-as-kill (point-min) (point-max))
+ (goto-char (point-min))
+ (insert (format antlr-help-rules-intro dirname)))))
+
+;;;###autoload
+(defun antlr-show-makefile-rules ()
+ "Show Makefile rules for all grammar files in the current directory.
+If the `major-mode' of the current buffer has the value `makefile-mode',
+the rules are directory inserted at point. Otherwise, a *Help* buffer
+is shown with the rules which are also put into the `kill-ring' for
+\\[yank].
+
+This command considers import/export vocabularies and grammar
+inheritance and provides a value for the \"-glib\" option if necessary.
+Customize variable `antlr-makefile-specification' for the appearance of
+the rules.
+
+If the file for a super-grammar cannot be determined, special file names
+are used according to variable `antlr-unknown-file-formats' and a
+commentary with value `antlr-help-unknown-file-text' is added. The
+*Help* buffer always starts with the text in `antlr-help-rules-intro'."
+ (interactive)
+ (if (null (eq major-mode 'makefile-mode))
+ (antlr-with-displaying-help-buffer 'antlr-insert-makefile-rules)
+ (push-mark)
+ (antlr-insert-makefile-rules t)))
+
+