| ;;; -*- lexical-binding: t; -*- |
| |
| ;; Author: Andrea Corallo <andrea.corallo@arm.com> |
| ;; Package: mdcompact |
| ;; Keywords: languages, extensions |
| ;; Package-Requires: ((emacs "29")) |
| |
| ;; This file is part of GCC. |
| |
| ;; GCC 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. |
| |
| ;; GCC 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 GCC. If not, see <https://www.gnu.org/licenses/>. |
| |
| ;;; Commentary: |
| |
| ;; Convert multi choice GCC machine description patterns to compact |
| ;; syntax. |
| |
| ;;; Usage: |
| |
| ;; With the point on a pattern run 'M-x mdcomp-run-at-point' to |
| ;; convert that pattern. |
| |
| ;; Run 'M-x mdcomp-run-buffer' to convert all convertible patterns in |
| ;; the current buffer. |
| |
| ;; Run 'M-x mdcomp-run-directory' to convert all convertible patterns |
| ;; in a directory. |
| |
| ;; One can invoke the tool from shell as well, ex for running it on |
| ;; the arm backend from the GCC checkout directory: |
| ;; emacs -batch -l ./contrib/mdcompact/mdcompact.el -f mdcomp-run-directory ./gcc/config/arm/ |
| |
| ;;; Code: |
| |
| (require 'cl-lib) |
| (require 'rx) |
| |
| (defconst |
| mdcomp-constr-rx |
| (rx "(match_operand" (? ":" (1+ (or punct alnum))) |
| (1+ space) (group-n 1 num) (1+ space) "\"" |
| (1+ (or alnum "_" "<" ">")) "\"" |
| (group-n 2 (1+ space) "\"" (group-n 3 (0+ (not "\""))) "\"") |
| ")")) |
| |
| (cl-defstruct mdcomp-operand |
| num |
| cstr) |
| |
| (cl-defstruct mdcomp-attr |
| name |
| vals) |
| |
| ;; A reasonable name |
| (rx-define mdcomp-name (1+ (or alnum "_"))) |
| |
| (defconst mdcomp-attr-rx |
| (rx "(set_attr" (1+ space) "\"" |
| (group-n 1 mdcomp-name) |
| "\"" (1+ space) "\"" |
| (group-n 2 (1+ (not ")"))) |
| "\"" (0+ space) ")")) |
| |
| (defun mdcomp-parse-delete-attr () |
| (save-match-data |
| (when (re-search-forward mdcomp-attr-rx nil t) |
| (let ((res (save-match-data |
| (make-mdcomp-attr |
| :name (match-string-no-properties 1) |
| :vals (cl-delete-if #'string-empty-p |
| (split-string |
| (replace-regexp-in-string |
| (rx "\\") "" |
| (match-string-no-properties 2)) |
| (rx (1+ (or space ","))))))))) |
| (if (length= (mdcomp-attr-vals res) 1) |
| 'short |
| (delete-region (match-beginning 0) (match-end 0)) |
| res))))) |
| |
| (defun mdcomp-parse-attrs () |
| (save-excursion |
| (let* ((res (cl-loop for x = (mdcomp-parse-delete-attr) |
| while x |
| collect x)) |
| (beg (re-search-backward (rx bol (1+ space) "[")))) |
| (unless (memq 'short res) |
| (when res |
| (delete-region beg (re-search-forward (rx "]"))))) |
| (cl-delete 'short res)))) |
| |
| (defun mdcomp-remove-quoting (beg) |
| (save-excursion |
| (save-match-data |
| (replace-regexp-in-region (regexp-quote "\\\\") "\\\\" beg (point-max)) |
| (replace-regexp-in-region (regexp-quote "\\\"") "\"" beg (point-max))))) |
| |
| (defun mdcomp-remove-escaped-newlines (beg) |
| (save-excursion |
| (save-match-data |
| (replace-regexp-in-region (rx "\\" eol (0+ space)) " " beg (point-max))))) |
| |
| (defun mdcomp-parse-delete-cstr () |
| (cl-loop while (re-search-forward mdcomp-constr-rx nil t) |
| unless (string= "" (match-string-no-properties 3)) |
| collect (save-match-data |
| (make-mdcomp-operand |
| :num (string-to-number (match-string-no-properties 1)) |
| :cstr (cl-delete-if #'string-empty-p |
| (split-string |
| (replace-regexp-in-string " " "" |
| (match-string-no-properties 3)) |
| (rx (1+ ",")))))) |
| do (delete-region (match-beginning 2) (match-end 2)))) |
| |
| (defun mdcomp-run* () |
| (let* ((ops (mdcomp-parse-delete-cstr)) |
| (attrs (mdcomp-parse-attrs)) |
| (beg (re-search-forward "\"@"))) |
| (cl-sort ops (lambda (x y) |
| (< (mdcomp-operand-num x) (mdcomp-operand-num y)))) |
| (mdcomp-remove-escaped-newlines beg) |
| (save-match-data |
| (save-excursion |
| (left-char 2) |
| (forward-sexp) |
| (left-char 1) |
| (delete-char 1) |
| (insert "\n }"))) |
| (mdcomp-remove-quoting beg) |
| (replace-match "{@") |
| (re-search-forward (rx (or "\"" ")"))) |
| (re-search-backward "@") |
| (right-char 1) |
| (insert "[ cons: ") |
| (cl-loop |
| for op in ops |
| when (string-match "=" (cl-first (mdcomp-operand-cstr op))) |
| do (insert "=") |
| do (insert (number-to-string (mdcomp-operand-num op)) ", ") |
| finally |
| (progn |
| ;; In case add attributes names |
| (when attrs |
| (delete-char -2) |
| (insert "; attrs: ") |
| (cl-loop for attr in attrs |
| do (insert (mdcomp-attr-name attr) ", "))) |
| (delete-char -2) |
| (insert "]"))) |
| (cl-loop |
| while (re-search-forward (rx bol (0+ space) (or (group-n 1 "* return") |
| (group-n 2 "}") |
| "#" alpha "<")) |
| nil t) |
| for i from 0 |
| when (match-string 2) |
| do (cl-return) |
| when (match-string 1) |
| do (progn |
| (delete-region (match-beginning 1) (+ (match-beginning 1) (length "* return"))) |
| (insert "<<") |
| (left-char 1)) |
| do |
| (progn |
| (left-char 1) |
| (cl-loop |
| initially (insert " [ ") |
| for op in ops |
| for c = (nth i (mdcomp-operand-cstr op)) |
| unless c |
| do (cl-return) |
| do (insert (if (string-match "=" c) |
| (substring c 1 nil) |
| c) |
| ", ") |
| finally (progn |
| (when attrs |
| (delete-char -2) |
| (insert "; ") |
| (cl-loop for attr in attrs |
| for str = (nth i (mdcomp-attr-vals attr)) |
| when str |
| do (insert str) |
| do (insert ", "))) |
| (delete-char -2) |
| (insert " ] ") |
| (move-end-of-line 1))))) |
| ;; remove everything after ] align what needs to be aligned |
| ;; and re-add the asm template |
| (re-search-backward (regexp-quote "@[ cons:")) |
| (let* ((n (length (mdcomp-operand-cstr (car ops)))) |
| (asms (cl-loop |
| initially (re-search-forward "]") |
| repeat n |
| collect (let* ((beg (re-search-forward "]")) |
| (end (re-search-forward (rx eol))) |
| (str (buffer-substring-no-properties beg end))) |
| (delete-region beg end) |
| str))) |
| (beg (re-search-backward (regexp-quote "@[ cons:"))) |
| (indent-tabs-mode nil)) |
| (re-search-forward "}") |
| (align-regexp beg (point) (rx (group-n 1 "") "[")) |
| (align-regexp beg (point) (rx (group-n 1 "") (or "," ";")) nil nil t) |
| (align-regexp beg (point) (rx (group-n 1 "") "]")) |
| (goto-char beg) |
| (cl-loop |
| initially (re-search-forward "]") |
| for i below n |
| do (progn |
| (re-search-forward "]") |
| (insert (nth i asms)))) |
| (when (re-search-forward (rx (1+ (or space eol)) ")") nil t) |
| (replace-match "\n)" nil t))))) |
| |
| (defun mdcomp-narrow-to-md-pattern () |
| (condition-case nil |
| (let ((beg (re-search-forward "\n(")) |
| (end (re-search-forward (rx bol (1+ ")"))))) |
| (narrow-to-region beg end)) |
| (error |
| (narrow-to-defun)))) |
| |
| (defun mdcomp-run-at-point () |
| "Convert the multi choice top-level form around point to compact syntax." |
| (interactive) |
| (save-restriction |
| (save-mark-and-excursion |
| (mdcomp-narrow-to-md-pattern) |
| (goto-char (point-min)) |
| (let ((pattern-name (save-excursion |
| (re-search-forward (rx "\"" (group-n 1 (1+ (not "\""))) "\"")) |
| (match-string-no-properties 1))) |
| (orig-text (buffer-substring-no-properties (point-min) (point-max)))) |
| (condition-case nil |
| (progn |
| (mdcomp-run*) |
| (message "Converted: %s" pattern-name)) |
| (error |
| (message "Skipping convertion for: %s" pattern-name) |
| (delete-region (point-min) (point-max)) |
| (insert orig-text) |
| 'fail)))))) |
| |
| (defun mdcomp-run-buffer () |
| "Convert the multi choice top-level forms in the buffer to compact syntax." |
| (interactive) |
| (save-excursion |
| (message "Conversion for buffer %s started" (buffer-file-name)) |
| (goto-char (point-min)) |
| (while (re-search-forward |
| (rx "match_operand" (1+ any) letter (0+ space) "," (0+ space) letter) nil t) |
| (when (eq (mdcomp-run-at-point) 'fail) |
| (condition-case nil |
| (forward-sexp) |
| (error |
| ;; If forward-sexp fails falls back. |
| (re-search-forward (rx ")" eol eol)))))) |
| (message "Conversion done"))) |
| |
| (defconst mdcomp-file-rx (rx bol alpha (0+ not-newline) ".md" eol)) |
| |
| (defun mdcomp-run-directory (folder &optional recursive) |
| "Run el mdcompact on a FOLDER possibly in a RECURSIVE fashion." |
| (interactive "D") |
| (let ((before-save-hook nil) |
| (init-time (current-time))) |
| (mapc (lambda (f) |
| (with-temp-file f |
| (message "Working on %s" f) |
| (insert-file-contents f) |
| (mdcomp-run-buffer) |
| (message "Done with %s" f))) |
| (if recursive |
| (directory-files-recursively folder mdcomp-file-rx) |
| (directory-files folder t mdcomp-file-rx))) |
| (message "Converted in %f sec" (float-time (time-since init-time))))) |
| |
| (defun mdcomp-batch-run-directory () |
| "Same as `mdcomp-run-directory' but use cmd line args." |
| (mdcomp-run-directory (nth 0 argv) (nth 1 argv))) |
| |
| (provide 'mdcompact) |
| |
| ;;; mdcompact.el ends here |