+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Initialization
+
+;; add speedbar
+(when (fboundp 'speedbar)
+ (condition-case ()
+ (when (and vhdl-speedbar-auto-open
+ (not (and (boundp 'speedbar-frame)
+ (frame-live-p speedbar-frame))))
+ (speedbar-frame-mode 1)
+ (if (fboundp 'speedbar-select-attached-frame)
+ (speedbar-select-attached-frame)
+ (select-frame speedbar-attached-frame)))
+ (error (vhdl-warning-when-idle "ERROR: An error occurred while opening speedbar"))))
+
+;; initialize speedbar
+(if (not (boundp 'speedbar-frame))
+ (add-hook 'speedbar-load-hook 'vhdl-speedbar-initialize)
+ (vhdl-speedbar-initialize)
+ (when speedbar-frame (vhdl-speedbar-refresh)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Structural composition
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun vhdl-get-components-package-name ()
+ "Return the name of the components package."
+ (let ((project (vhdl-project-p)))
+ (if project
+ (vhdl-replace-string (car vhdl-components-package-name)
+ (subst-char-in-string ? ?_ project))
+ (cdr vhdl-components-package-name))))
+
+(defun vhdl-compose-new-component ()
+ "Create entity and architecture for new component."
+ (interactive)
+ (let* ((case-fold-search t)
+ (ent-name (read-from-minibuffer "entity name: "
+ nil vhdl-minibuffer-local-map))
+ (arch-name
+ (if (equal (cdr vhdl-compose-architecture-name) "")
+ (read-from-minibuffer "architecture name: "
+ nil vhdl-minibuffer-local-map)
+ (vhdl-replace-string vhdl-compose-architecture-name ent-name)))
+ ent-file-name arch-file-name ent-buffer arch-buffer project)
+ (message "Creating component \"%s(%s)\"..." ent-name arch-name)
+ ;; open entity file
+ (unless (eq vhdl-compose-create-files 'none)
+ (setq ent-file-name
+ (concat (vhdl-replace-string vhdl-entity-file-name ent-name t)
+ "." (file-name-extension (buffer-file-name))))
+ (when (and (file-exists-p ent-file-name)
+ (not (y-or-n-p (concat "File \"" ent-file-name
+ "\" exists; overwrite? "))))
+ (error "ERROR: Creating component...aborted"))
+ (find-file ent-file-name)
+ (erase-buffer)
+ (set-buffer-modified-p nil))
+ ;; insert header
+ (if vhdl-compose-include-header
+ (progn (vhdl-template-header)
+ (goto-char (point-max)))
+ (vhdl-comment-display-line) (insert "\n\n"))
+ ;; insert library clause
+ (vhdl-template-package-std-logic-1164)
+ (when vhdl-use-components-package
+ (insert "\n")
+ (vhdl-template-standard-package (vhdl-work-library)
+ (vhdl-get-components-package-name)))
+ (insert "\n\n") (vhdl-comment-display-line) (insert "\n\n")
+ ;; insert entity declaration
+ (vhdl-insert-keyword "ENTITY ") (insert ent-name)
+ (vhdl-insert-keyword " IS\n")
+ (when (memq vhdl-insert-empty-lines '(unit all)) (insert "\n"))
+ (indent-to vhdl-basic-offset) (vhdl-insert-keyword "GENERIC (\n")
+ (indent-to (* 2 vhdl-basic-offset)) (insert ");\n")
+ (when (memq vhdl-insert-empty-lines '(unit all)) (insert "\n"))
+ (indent-to vhdl-basic-offset) (vhdl-insert-keyword "PORT (\n")
+ (indent-to (* 2 vhdl-basic-offset)) (insert ");\n")
+ (when (memq vhdl-insert-empty-lines '(unit all)) (insert "\n"))
+ (vhdl-insert-keyword "END ")
+ (unless (vhdl-standard-p '87) (vhdl-insert-keyword "ENTITY "))
+ (insert ent-name ";\n\n")
+ (vhdl-comment-display-line) (insert "\n")
+ ;; open architecture file
+ (if (not (eq vhdl-compose-create-files 'separate))
+ (insert "\n")
+ (setq ent-buffer (current-buffer))
+ (setq arch-file-name
+ (concat (vhdl-replace-string vhdl-architecture-file-name
+ (concat ent-name " " arch-name) t)
+ "." (file-name-extension (buffer-file-name))))
+ (when (and (file-exists-p arch-file-name)
+ (not (y-or-n-p (concat "File \"" arch-file-name
+ "\" exists; overwrite? "))))
+ (error "ERROR: Creating component...aborted"))
+ (find-file arch-file-name)
+ (erase-buffer)
+ (set-buffer-modified-p nil)
+ ;; insert header
+ (if vhdl-compose-include-header
+ (progn (vhdl-template-header)
+ (goto-char (point-max)))
+ (vhdl-comment-display-line) (insert "\n\n")))
+ ;; insert architecture body
+ (vhdl-insert-keyword "ARCHITECTURE ") (insert arch-name)
+ (vhdl-insert-keyword " OF ") (insert ent-name)
+ (vhdl-insert-keyword " IS\n\n")
+ (indent-to vhdl-basic-offset) (vhdl-comment-display-line) (insert "\n")
+ (indent-to vhdl-basic-offset) (insert "-- Internal signal declarations\n")
+ (indent-to vhdl-basic-offset) (vhdl-comment-display-line) (insert "\n\n")
+ (unless (or vhdl-use-components-package (vhdl-use-direct-instantiation))
+ (indent-to vhdl-basic-offset) (vhdl-comment-display-line) (insert "\n")
+ (indent-to vhdl-basic-offset) (insert "-- Component declarations\n")
+ (indent-to vhdl-basic-offset) (vhdl-comment-display-line) (insert "\n\n"))
+ (vhdl-insert-keyword "BEGIN")
+ (when vhdl-self-insert-comments
+ (insert " -- ")
+ (unless (vhdl-standard-p '87) (vhdl-insert-keyword "ARCHITECTURE "))
+ (insert arch-name))
+ (insert "\n\n")
+ (indent-to vhdl-basic-offset) (vhdl-comment-display-line) (insert "\n")
+ (indent-to vhdl-basic-offset) (insert "-- Component instantiations\n")
+ (indent-to vhdl-basic-offset) (vhdl-comment-display-line) (insert "\n\n")
+ (vhdl-insert-keyword "END ")
+ (unless (vhdl-standard-p '87) (vhdl-insert-keyword "ARCHITECTURE "))
+ (insert arch-name ";\n\n")
+ ;; insert footer and save
+ (if (and vhdl-compose-include-header (not (equal vhdl-file-footer "")))
+ (vhdl-template-footer)
+ (vhdl-comment-display-line) (insert "\n"))
+ (goto-char (point-min))
+ (setq arch-buffer (current-buffer))
+ (when ent-buffer (set-buffer ent-buffer) (save-buffer))
+ (set-buffer arch-buffer) (save-buffer)
+ (message "%s"
+ (concat (format "Creating component \"%s(%s)\"...done" ent-name arch-name)
+ (and ent-file-name
+ (format "\n File created: \"%s\"" ent-file-name))
+ (and arch-file-name
+ (format "\n File created: \"%s\"" arch-file-name))))))
+
+(defun vhdl-compose-place-component ()
+ "Place new component by pasting current port as component declaration and
+component instantiation."
+ (interactive)
+ (if (not vhdl-port-list)
+ (error "ERROR: No port has been read")
+ (save-excursion
+ (vhdl-prepare-search-2
+ (unless (or (re-search-backward "^architecture[ \t\n]+\\w+[ \t\n]+of[ \t\n]+\\(\\w+\\)[ \t\n]+is\\>" nil t)
+ (re-search-forward "^architecture[ \t\n]+\\w+[ \t\n]+of[ \t\n]+\\(\\w+\\)[ \t\n]+is\\>" nil t))
+ (error "ERROR: No architecture found"))
+ (let* ((ent-name (match-string 1))
+ (ent-file-name
+ (concat (vhdl-replace-string vhdl-entity-file-name ent-name t)
+ "." (file-name-extension (buffer-file-name))))
+ (orig-buffer (current-buffer)))
+ (message "Placing component \"%s\"..." (nth 0 vhdl-port-list))
+ ;; place component declaration
+ (unless (or vhdl-use-components-package
+ (vhdl-use-direct-instantiation)
+ (save-excursion
+ (re-search-forward
+ (concat "^\\s-*component\\s-+"
+ (car vhdl-port-list) "\\>") nil t)))
+ (re-search-forward "^begin\\>" nil)
+ (beginning-of-line)
+ (skip-chars-backward " \t\n")
+ (insert "\n\n") (indent-to vhdl-basic-offset)
+ (vhdl-port-paste-component t))
+ ;; place component instantiation
+ (re-search-forward "^end\\>" nil)
+ (beginning-of-line)
+ (skip-chars-backward " \t\n")
+ (insert "\n\n") (indent-to vhdl-basic-offset)
+ (vhdl-port-paste-instance nil t t)
+ ;; place use clause for used packages
+ (when (nth 3 vhdl-port-list)
+ ;; open entity file
+ (when (file-exists-p ent-file-name)
+ (find-file ent-file-name))
+ (goto-char (point-min))
+ (unless (re-search-forward (concat "^entity[ \t\n]+" ent-name "[ \t\n]+is\\>") nil t)
+ (error "ERROR: Entity not found: \"%s\"" ent-name))
+ (goto-char (match-beginning 0))
+ (if (and (save-excursion
+ (re-search-backward "^\\(library\\|use\\)\\|end\\>" nil t))
+ (match-string 1))
+ (progn (goto-char (match-end 0))
+ (beginning-of-line 2))
+ (insert "\n")
+ (backward-char))
+ (vhdl-port-paste-context-clause)
+ (switch-to-buffer orig-buffer))
+ (message "Placing component \"%s\"...done" (nth 0 vhdl-port-list)))))))
+
+(defun vhdl-compose-wire-components ()
+ "Connect components."
+ (interactive)
+ (save-excursion
+ (vhdl-prepare-search-2
+ (unless (or (re-search-backward "^architecture[ \t\n]+\\w+[ \t\n]+of[ \t\n]+\\(\\w+\\)[ \t\n]+is\\>" nil t)
+ (re-search-forward "^architecture[ \t\n]+\\w+[ \t\n]+of[ \t\n]+\\(\\w+\\)[ \t\n]+is\\>" nil t))
+ (error "ERROR: No architecture found"))
+ (let* ((ent-name (match-string 1))
+ (ent-file-name
+ (concat (vhdl-replace-string vhdl-entity-file-name ent-name t)
+ "." (file-name-extension (buffer-file-name))))
+ (arch-decl-pos (point-marker))
+ (arch-stat-pos (re-search-forward "^begin\\>" nil))
+ (arch-end-pos (re-search-forward "^end\\>" nil))
+ (pack-name (vhdl-get-components-package-name))
+ (pack-file-name
+ (concat (vhdl-replace-string vhdl-package-file-name pack-name t)
+ "." (file-name-extension (buffer-file-name))))
+ inst-name comp-name comp-ent-name comp-ent-file-name has-generic
+ port-alist generic-alist inst-alist
+ signal-name signal-entry signal-alist local-list written-list
+ single-in-list multi-in-list single-out-list multi-out-list
+ constant-name constant-entry constant-alist single-list multi-list
+ port-beg-pos port-in-pos port-out-pos port-inst-pos port-end-pos
+ generic-beg-pos generic-pos generic-inst-pos generic-end-pos
+ signal-beg-pos signal-pos
+ constant-temp-pos port-temp-pos signal-temp-pos)
+ (message "Wiring components...")
+ ;; process all instances
+ (goto-char arch-stat-pos)
+ (while (re-search-forward
+ (concat "^[ \t]*\\(\\w+\\)[ \t\n]*:[ \t\n]*\\("
+ "\\(component[ \t\n]+\\)?\\(\\w+\\)"
+ "[ \t\n]+\\(--[^\n]*\n[ \t\n]*\\)*\\(\\(generic\\)\\|port\\)[ \t\n]+map\\|"
+ "\\(\\(entity\\)\\|configuration\\)[ \t\n]+\\(\\(\\w+\\)\\.\\)?\\(\\w+\\)\\([ \t\n]*(\\(\\w+\\))\\)?"
+ "[ \t\n]+\\(--[^\n]*\n[ \t\n]*\\)*\\(\\(generic\\)\\|port\\)[ \t\n]+map\\)[ \t\n]*(") arch-end-pos t)
+ (setq inst-name (match-string-no-properties 1)
+ comp-name (match-string-no-properties 4)
+ comp-ent-name (match-string-no-properties 12)
+ has-generic (or (match-string 7) (match-string 17)))
+ ;; get port ...
+ (if comp-name
+ ;; ... from component declaration
+ (vhdl-visit-file
+ (when vhdl-use-components-package pack-file-name) t
+ (save-excursion
+ (goto-char (point-min))
+ (unless (re-search-forward (concat "^\\s-*component[ \t\n]+" comp-name "\\>") nil t)
+ (error "ERROR: Component declaration not found: \"%s\"" comp-name))
+ (vhdl-port-copy)))
+ ;; ... from entity declaration (direct instantiation)
+ (setq comp-ent-file-name
+ (concat (vhdl-replace-string vhdl-entity-file-name comp-ent-name t)
+ "." (file-name-extension (buffer-file-name))))
+ (vhdl-visit-file
+ comp-ent-file-name t
+ (save-excursion
+ (goto-char (point-min))
+ (unless (re-search-forward (concat "^\\s-*entity[ \t\n]+" comp-ent-name "\\>") nil t)
+ (error "ERROR: Entity declaration not found: \"%s\"" comp-ent-name))
+ (vhdl-port-copy))))
+ (vhdl-port-flatten t)
+ (setq generic-alist (nth 1 vhdl-port-list)
+ port-alist (nth 2 vhdl-port-list)
+ vhdl-port-list nil)
+ (setq constant-alist nil
+ signal-alist nil)
+ (when has-generic
+ ;; process all constants in generic map
+ (vhdl-forward-syntactic-ws)
+ (while (vhdl-parse-string "\\(\\(\\w+\\)[ \t\n]*=>[ \t\n]*\\)?\\(\\w+\\),?" t)
+ (setq constant-name (match-string-no-properties 3))
+ (setq constant-entry
+ (cons constant-name
+ (if (match-string 1)
+ (or (aget generic-alist (match-string 2) t)
+ (error "ERROR: Formal generic \"%s\" mismatch for instance \"%s\"" (match-string 2) inst-name))
+ (cdar generic-alist))))
+ (setq constant-alist (cons constant-entry constant-alist))
+ (setq constant-name (downcase constant-name))
+ (if (or (member constant-name single-list)
+ (member constant-name multi-list))
+ (progn (setq single-list (delete constant-name single-list))
+ (add-to-list 'multi-list constant-name))
+ (add-to-list 'single-list constant-name))
+ (unless (match-string 1)
+ (setq generic-alist (cdr generic-alist)))
+ (vhdl-forward-syntactic-ws))
+ (vhdl-re-search-forward "\\<port\\s-+map[ \t\n]*(" nil t))
+ ;; process all signals in port map
+ (vhdl-forward-syntactic-ws)
+ (while (vhdl-parse-string "\\(\\(\\w+\\)[ \t\n]*=>[ \t\n]*\\)?\\(\\w+\\),?" t)
+ (setq signal-name (match-string-no-properties 3))
+ (setq signal-entry (cons signal-name
+ (if (match-string 1)
+ (or (aget port-alist (match-string 2) t)
+ (error "ERROR: Formal port \"%s\" mismatch for instance \"%s\"" (match-string 2) inst-name))
+ (cdar port-alist))))
+ (setq signal-alist (cons signal-entry signal-alist))
+ (setq signal-name (downcase signal-name))
+ (if (equal (upcase (nth 2 signal-entry)) "IN")
+ ;; input signal
+ (cond
+ ((member signal-name local-list)
+ nil)
+ ((or (member signal-name single-out-list)
+ (member signal-name multi-out-list))
+ (setq single-out-list (delete signal-name single-out-list))
+ (setq multi-out-list (delete signal-name multi-out-list))
+ (add-to-list 'local-list signal-name))
+ ((member signal-name single-in-list)
+ (setq single-in-list (delete signal-name single-in-list))
+ (add-to-list 'multi-in-list signal-name))
+ ((not (member signal-name multi-in-list))
+ (add-to-list 'single-in-list signal-name)))
+ ;; output signal
+ (cond
+ ((member signal-name local-list)
+ nil)
+ ((or (member signal-name single-in-list)
+ (member signal-name multi-in-list))
+ (setq single-in-list (delete signal-name single-in-list))
+ (setq multi-in-list (delete signal-name multi-in-list))
+ (add-to-list 'local-list signal-name))
+ ((member signal-name single-out-list)
+ (setq single-out-list (delete signal-name single-out-list))
+ (add-to-list 'multi-out-list signal-name))
+ ((not (member signal-name multi-out-list))
+ (add-to-list 'single-out-list signal-name))))
+ (unless (match-string 1)
+ (setq port-alist (cdr port-alist)))
+ (vhdl-forward-syntactic-ws))
+ (setq inst-alist (cons (list inst-name (nreverse constant-alist)
+ (nreverse signal-alist)) inst-alist)))
+ ;; prepare signal insertion
+ (vhdl-goto-marker arch-decl-pos)
+ (forward-line 1)
+ (re-search-forward "^\\s-*-- Internal signal declarations[ \t\n]*-*\n" arch-stat-pos t)
+ (setq signal-pos (point-marker))
+ (while (progn (vhdl-forward-syntactic-ws)
+ (looking-at "signal\\>"))
+ (beginning-of-line 2)
+ (delete-region signal-pos (point)))
+ (setq signal-beg-pos signal-pos)
+ ;; open entity file
+ (when (file-exists-p ent-file-name)
+ (find-file ent-file-name))
+ (goto-char (point-min))
+ (unless (re-search-forward (concat "^entity[ \t\n]+" ent-name "[ \t\n]+is\\>") nil t)
+ (error "ERROR: Entity not found: \"%s\"" ent-name))
+ ;; prepare generic clause insertion
+ (unless (and (re-search-forward "\\(^\\s-*generic[ \t\n]*(\\)\\|^end\\>" nil t)
+ (match-string 1))
+ (goto-char (match-beginning 0))
+ (indent-to vhdl-basic-offset)
+ (insert "generic ();\n\n")
+ (backward-char 4))
+ (backward-char)
+ (setq generic-pos (point-marker))
+ (forward-sexp) (end-of-line)
+ (delete-region generic-pos (point)) (delete-char 1)
+ (insert "(\n")
+ (when multi-list
+ (insert "\n")
+ (indent-to (* 2 vhdl-basic-offset))
+ (insert "-- global generics\n"))
+ (setq generic-beg-pos (point-marker) generic-pos (point-marker)
+ generic-inst-pos (point-marker) generic-end-pos (point-marker))
+ ;; prepare port clause insertion
+ (unless (and (re-search-forward "\\(^\\s-*port[ \t\n]*(\\)\\|^end\\>" nil t)
+ (match-string 1))
+ (goto-char (match-beginning 0))
+ (indent-to vhdl-basic-offset)
+ (insert "port ();\n\n")
+ (backward-char 4))
+ (backward-char)
+ (setq port-in-pos (point-marker))
+ (forward-sexp) (end-of-line)
+ (delete-region port-in-pos (point)) (delete-char 1)
+ (insert "(\n")
+ (when (or multi-in-list multi-out-list)
+ (insert "\n")
+ (indent-to (* 2 vhdl-basic-offset))
+ (insert "-- global ports\n"))
+ (setq port-beg-pos (point-marker) port-in-pos (point-marker)
+ port-out-pos (point-marker) port-inst-pos (point-marker)
+ port-end-pos (point-marker))
+ ;; insert generics, ports and signals
+ (setq inst-alist (nreverse inst-alist))
+ (while inst-alist
+ (setq inst-name (nth 0 (car inst-alist))
+ constant-alist (nth 1 (car inst-alist))
+ signal-alist (nth 2 (car inst-alist))
+ constant-temp-pos generic-inst-pos
+ port-temp-pos port-inst-pos
+ signal-temp-pos signal-pos)
+ ;; generics
+ (while constant-alist
+ (setq constant-name (downcase (caar constant-alist))
+ constant-entry (car constant-alist))
+ (cond ((member constant-name written-list)
+ nil)
+ ((member constant-name multi-list)
+ (vhdl-goto-marker generic-pos)
+ (setq generic-end-pos
+ (vhdl-max-marker
+ generic-end-pos
+ (vhdl-compose-insert-generic constant-entry)))
+ (setq generic-pos (point-marker))
+ (add-to-list 'written-list constant-name))
+ (t
+ (vhdl-goto-marker
+ (vhdl-max-marker generic-inst-pos generic-pos))
+ (setq generic-end-pos
+ (vhdl-compose-insert-generic constant-entry))
+ (setq generic-inst-pos (point-marker))
+ (add-to-list 'written-list constant-name)))
+ (setq constant-alist (cdr constant-alist)))
+ (when (/= constant-temp-pos generic-inst-pos)
+ (vhdl-goto-marker (vhdl-max-marker constant-temp-pos generic-pos))
+ (insert "\n") (indent-to (* 2 vhdl-basic-offset))
+ (insert "-- generics for \"" inst-name "\"\n")
+ (vhdl-goto-marker generic-inst-pos))
+ ;; ports and signals
+ (while signal-alist
+ (setq signal-name (downcase (caar signal-alist))
+ signal-entry (car signal-alist))
+ (cond ((member signal-name written-list)
+ nil)
+ ((member signal-name multi-in-list)
+ (vhdl-goto-marker port-in-pos)
+ (setq port-end-pos
+ (vhdl-max-marker
+ port-end-pos (vhdl-compose-insert-port signal-entry)))
+ (setq port-in-pos (point-marker))
+ (add-to-list 'written-list signal-name))
+ ((member signal-name multi-out-list)
+ (vhdl-goto-marker (vhdl-max-marker port-out-pos port-in-pos))
+ (setq port-end-pos
+ (vhdl-max-marker
+ port-end-pos (vhdl-compose-insert-port signal-entry)))
+ (setq port-out-pos (point-marker))
+ (add-to-list 'written-list signal-name))
+ ((or (member signal-name single-in-list)
+ (member signal-name single-out-list))
+ (vhdl-goto-marker
+ (vhdl-max-marker
+ port-inst-pos
+ (vhdl-max-marker port-out-pos port-in-pos)))
+ (setq port-end-pos (vhdl-compose-insert-port signal-entry))
+ (setq port-inst-pos (point-marker))
+ (add-to-list 'written-list signal-name))
+ ((equal (upcase (nth 2 signal-entry)) "OUT")
+ (vhdl-goto-marker signal-pos)
+ (vhdl-compose-insert-signal signal-entry)
+ (setq signal-pos (point-marker))
+ (add-to-list 'written-list signal-name)))
+ (setq signal-alist (cdr signal-alist)))
+ (when (/= port-temp-pos port-inst-pos)
+ (vhdl-goto-marker
+ (vhdl-max-marker port-temp-pos
+ (vhdl-max-marker port-in-pos port-out-pos)))
+ (insert "\n") (indent-to (* 2 vhdl-basic-offset))
+ (insert "-- ports to \"" inst-name "\"\n")
+ (vhdl-goto-marker port-inst-pos))
+ (when (/= signal-temp-pos signal-pos)
+ (vhdl-goto-marker signal-temp-pos)
+ (insert "\n") (indent-to vhdl-basic-offset)
+ (insert "-- outputs of \"" inst-name "\"\n")
+ (vhdl-goto-marker signal-pos))
+ (setq inst-alist (cdr inst-alist)))
+ ;; finalize generic/port clause
+ (vhdl-goto-marker generic-end-pos) (backward-char)
+ (when (= generic-beg-pos generic-end-pos)
+ (insert "\n") (indent-to (* 2 vhdl-basic-offset))
+ (insert ";") (backward-char))
+ (insert ")")
+ (vhdl-goto-marker port-end-pos) (backward-char)
+ (when (= port-beg-pos port-end-pos)
+ (insert "\n") (indent-to (* 2 vhdl-basic-offset))
+ (insert ";") (backward-char))
+ (insert ")")
+ ;; align everything
+ (when vhdl-auto-align
+ (vhdl-goto-marker generic-beg-pos)
+ (vhdl-align-region-groups generic-beg-pos generic-end-pos 1)
+ (vhdl-align-region-groups port-beg-pos port-end-pos 1)
+ (vhdl-goto-marker signal-beg-pos)
+ (vhdl-align-region-groups signal-beg-pos signal-pos))
+ (switch-to-buffer (marker-buffer signal-beg-pos))
+ (message "Wiring components...done")))))
+
+(defun vhdl-compose-insert-generic (entry)
+ "Insert ENTRY as generic declaration."
+ (let (pos)
+ (indent-to (* 2 vhdl-basic-offset))
+ (insert (nth 0 entry) " : " (nth 1 entry))
+ (when (nth 2 entry)
+ (insert " := " (nth 2 entry)))
+ (insert ";")
+ (setq pos (point-marker))
+ (when (and vhdl-include-port-comments (nth 3 entry))
+ (vhdl-comment-insert-inline (nth 3 entry) t))
+ (insert "\n")
+ pos))
+
+(defun vhdl-compose-insert-port (entry)
+ "Insert ENTRY as port declaration."
+ (let (pos)
+ (indent-to (* 2 vhdl-basic-offset))
+ (insert (nth 0 entry) " : " (nth 2 entry) " " (nth 3 entry) ";")
+ (setq pos (point-marker))
+ (when (and vhdl-include-port-comments (nth 4 entry))
+ (vhdl-comment-insert-inline (nth 4 entry) t))
+ (insert "\n")
+ pos))
+
+(defun vhdl-compose-insert-signal (entry)
+ "Insert ENTRY as signal declaration."
+ (indent-to vhdl-basic-offset)
+ (insert "signal " (nth 0 entry) " : " (nth 3 entry) ";")
+ (when (and vhdl-include-port-comments (nth 4 entry))
+ (vhdl-comment-insert-inline (nth 4 entry) t))
+ (insert "\n"))
+
+(defun vhdl-compose-components-package ()
+ "Generate a package containing component declarations for all entities in the
+current project/directory."
+ (interactive)
+ (vhdl-require-hierarchy-info)
+ (let* ((project (vhdl-project-p))
+ (pack-name (vhdl-get-components-package-name))
+ (pack-file-name
+ (concat (vhdl-replace-string vhdl-package-file-name pack-name t)
+ "." (file-name-extension (buffer-file-name))))
+ (ent-alist (aget vhdl-entity-alist
+ (or project default-directory) t))
+ (lazy-lock-minimum-size 0)
+ clause-pos component-pos)
+ (message "Generating components package \"%s\"..." pack-name)
+ ;; open package file
+ (when (and (file-exists-p pack-file-name)
+ (not (y-or-n-p (concat "File \"" pack-file-name
+ "\" exists; overwrite? "))))
+ (error "ERROR: Generating components package...aborted"))
+ (find-file pack-file-name)
+ (erase-buffer)
+ ;; insert header
+ (if vhdl-compose-include-header
+ (progn (vhdl-template-header
+ (concat "Components package (generated by Emacs VHDL Mode "
+ vhdl-version ")"))
+ (goto-char (point-max)))
+ (vhdl-comment-display-line) (insert "\n\n"))
+ ;; insert std_logic_1164 package
+ (vhdl-template-package-std-logic-1164)
+ (insert "\n") (setq clause-pos (point-marker))
+ (insert "\n") (vhdl-comment-display-line) (insert "\n\n")
+ ;; insert package declaration
+ (vhdl-insert-keyword "PACKAGE ") (insert pack-name)
+ (vhdl-insert-keyword " IS\n\n")
+ (indent-to vhdl-basic-offset) (vhdl-comment-display-line) (insert "\n")
+ (indent-to vhdl-basic-offset) (insert "-- Component declarations\n")
+ (indent-to vhdl-basic-offset) (vhdl-comment-display-line) (insert "\n\n")
+ (indent-to vhdl-basic-offset)
+ (setq component-pos (point-marker))
+ (insert "\n\n") (vhdl-insert-keyword "END ")
+ (unless (vhdl-standard-p '87) (vhdl-insert-keyword "PACKAGE "))
+ (insert pack-name ";\n\n")
+ ;; insert footer
+ (if (and vhdl-compose-include-header (not (equal vhdl-file-footer "")))
+ (vhdl-template-footer)
+ (vhdl-comment-display-line) (insert "\n"))
+ ;; insert component declarations
+ (while ent-alist
+ (vhdl-visit-file (nth 2 (car ent-alist)) nil
+ (progn (goto-line (nth 3 (car ent-alist)))
+ (end-of-line)
+ (vhdl-port-copy)))
+ (goto-char component-pos)
+ (vhdl-port-paste-component t)
+ (when (cdr ent-alist) (insert "\n\n") (indent-to vhdl-basic-offset))
+ (setq component-pos (point-marker))
+ (goto-char clause-pos)
+ (vhdl-port-paste-context-clause pack-name)
+ (setq clause-pos (point-marker))
+ (setq ent-alist (cdr ent-alist)))
+ (goto-char (point-min))
+ (save-buffer)
+ (message "Generating components package \"%s\"...done\n File created: \"%s\""
+ pack-name pack-file-name)))
+
+(defun vhdl-compose-configuration-architecture (ent-name arch-name inst-alist
+ &optional insert-conf)
+ "Generate block configuration for architecture."
+ (let ((margin (current-indentation))
+ (beg (save-excursion (beginning-of-line) (point)))
+ ent-entry inst-entry inst-path inst-prev-path cons-key tmp-alist)
+ ;; insert block configuration (for architecture)
+ (vhdl-insert-keyword "FOR ") (insert arch-name "\n")
+ (setq margin (+ margin vhdl-basic-offset))
+ ;; process all instances
+ (while inst-alist
+ (setq inst-entry (car inst-alist))
+ ;; is component?
+ (when (nth 4 inst-entry)
+ (setq insert-conf t)
+ (setq inst-path (nth 9 inst-entry))
+ ;; skip common path with previous instance
+ (while (and inst-path (equal (car inst-path) (car inst-prev-path)))
+ (setq inst-path (cdr inst-path)
+ inst-prev-path (cdr inst-prev-path)))
+ ;; insert block configuration end (for previous block/generate)
+ (while inst-prev-path
+ (setq margin (- margin vhdl-basic-offset))
+ (indent-to margin)
+ (vhdl-insert-keyword "END FOR;\n")
+ (setq inst-prev-path (cdr inst-prev-path)))
+ ;; insert block configuration beginning (for current block/generate)
+ (indent-to margin)
+ (while inst-path
+ (setq margin (+ margin vhdl-basic-offset))
+ (vhdl-insert-keyword "FOR ")
+ (insert (car inst-path) "\n")
+ (indent-to margin)
+ (setq inst-path (cdr inst-path)))
+ ;; insert component configuration beginning
+ (vhdl-insert-keyword "FOR ")
+ (insert (nth 1 inst-entry) " : " (nth 4 inst-entry) "\n")
+ ;; find subconfiguration
+ (setq conf-key (nth 7 inst-entry))
+ (setq tmp-alist conf-alist)
+ ;; use first configuration found for instance's entity
+ (while (and tmp-alist (null conf-key))
+ (when (equal (nth 5 inst-entry) (nth 4 (car tmp-alist)))
+ (setq conf-key (nth 0 (car tmp-alist))))
+ (setq tmp-alist (cdr tmp-alist)))
+ (setq conf-entry (aget conf-alist conf-key t))
+ ;; insert binding indication ...
+ ;; ... with subconfiguration (if exists)
+ (if (and vhdl-compose-configuration-use-subconfiguration conf-entry)
+ (progn
+ (indent-to (+ margin vhdl-basic-offset))
+ (vhdl-insert-keyword "USE CONFIGURATION ")
+ (insert (vhdl-work-library) "." (nth 0 conf-entry))
+ (insert ";\n"))
+ ;; ... with entity (if exists)
+ (setq ent-entry (aget ent-alist (nth 5 inst-entry) t))
+ (when ent-entry
+ (indent-to (+ margin vhdl-basic-offset))
+ (vhdl-insert-keyword "USE ENTITY ")
+ (insert (vhdl-work-library) "." (nth 0 ent-entry))
+ ;; insert architecture name (if architecture exists)
+ (when (nth 3 ent-entry)
+ (setq arch-name
+ ;; choose architecture name a) from configuration,
+ ;; b) from mra, or c) from first architecture
+ (or (nth 0 (aget (nth 3 ent-entry)
+ (or (nth 6 inst-entry)
+ (nth 4 ent-entry)) t))
+ (nth 1 (car (nth 3 ent-entry)))))
+ (insert "(" arch-name ")"))
+ (insert ";\n")
+ ;; insert block configuration (for architecture of subcomponent)
+ (when (and vhdl-compose-configuration-hierarchical
+ (nth 3 ent-entry))
+ (indent-to (+ margin vhdl-basic-offset))
+ (vhdl-compose-configuration-architecture
+ (nth 0 ent-entry) arch-name
+ (nth 3 (aget (nth 3 ent-entry) (downcase arch-name) t))))))
+ ;; insert component configuration end
+ (indent-to margin)
+ (vhdl-insert-keyword "END FOR;\n")
+ (setq inst-prev-path (nth 9 inst-entry)))
+ (setq inst-alist (cdr inst-alist)))
+ ;; insert block configuration end (for block/generate)
+ (while inst-prev-path
+ (setq margin (- margin vhdl-basic-offset))
+ (indent-to margin)
+ (vhdl-insert-keyword "END FOR;\n")
+ (setq inst-prev-path (cdr inst-prev-path)))
+ (indent-to (- margin vhdl-basic-offset))
+ ;; insert block configuration end or remove beginning (for architecture)
+ (if insert-conf
+ (vhdl-insert-keyword "END FOR;\n")
+ (delete-region beg (point)))))
+
+(defun vhdl-compose-configuration (&optional ent-name arch-name)
+ "Generate configuration declaration."
+ (interactive)
+ (vhdl-require-hierarchy-info)
+ (let ((ent-alist (aget vhdl-entity-alist
+ (or (vhdl-project-p) default-directory) t))
+ (conf-alist (aget vhdl-config-alist
+ (or (vhdl-project-p) default-directory) t))
+ (from-speedbar ent-name)
+ inst-alist conf-name conf-file-name pos)
+ (vhdl-prepare-search-2
+ ;; get entity and architecture name
+ (unless ent-name
+ (save-excursion
+ (unless (and (re-search-backward "^\\(architecture\\s-+\\(\\w+\\)\\s-+of\\s-+\\(\\w+\\)\\|end\\)\\>" nil t)
+ (not (equal "END" (upcase (match-string 1))))
+ (setq ent-name (match-string-no-properties 3))
+ (setq arch-name (match-string-no-properties 2)))
+ (error "ERROR: Not within an architecture"))))
+ (setq conf-name (vhdl-replace-string
+ vhdl-compose-configuration-name
+ (concat ent-name " " arch-name)))
+ (setq inst-alist
+ (nth 3 (aget (nth 3 (aget ent-alist (downcase ent-name) t))
+ (downcase arch-name) t))))
+ (message "Generating configuration \"%s\"..." conf-name)
+ (if vhdl-compose-configuration-create-file
+ ;; open configuration file
+ (progn
+ (setq conf-file-name
+ (concat (vhdl-replace-string vhdl-configuration-file-name
+ conf-name t)
+ "." (file-name-extension (buffer-file-name))))
+ (when (and (file-exists-p conf-file-name)
+ (not (y-or-n-p (concat "File \"" conf-file-name
+ "\" exists; overwrite? "))))
+ (error "ERROR: Creating configuration...aborted"))
+ (find-file conf-file-name)
+ (erase-buffer)
+ (set-buffer-modified-p nil)
+ ;; insert header
+ (if vhdl-compose-include-header
+ (progn (vhdl-template-header
+ (concat "Configuration declaration for design \""
+ ent-name "(" arch-name ")\""))
+ (goto-char (point-max)))
+ (vhdl-comment-display-line) (insert "\n\n")))
+ ;; goto end of architecture
+ (unless from-speedbar
+ (re-search-forward "^end\\>" nil)
+ (end-of-line) (insert "\n\n")
+ (vhdl-comment-display-line) (insert "\n\n")))
+ ;; insert library clause
+ (setq pos (point))
+ (vhdl-template-standard-package (vhdl-work-library) nil)
+ (when (/= pos (point))
+ (insert "\n\n"))
+ ;; insert configuration
+ (vhdl-insert-keyword "CONFIGURATION ") (insert conf-name)
+ (vhdl-insert-keyword " OF ") (insert ent-name)
+ (vhdl-insert-keyword " IS\n")
+ (indent-to vhdl-basic-offset)
+ ;; insert block configuration (for architecture)
+ (vhdl-compose-configuration-architecture ent-name arch-name inst-alist t)
+ (vhdl-insert-keyword "END ") (insert conf-name ";")
+ (when conf-file-name
+ ;; insert footer and save
+ (insert "\n\n")
+ (if (and vhdl-compose-include-header (not (equal vhdl-file-footer "")))
+ (vhdl-template-footer)
+ (vhdl-comment-display-line) (insert "\n"))
+ (save-buffer))
+ (message "%s"
+ (concat (format "Generating configuration \"%s\"...done" conf-name)
+ (and conf-file-name
+ (format "\n File created: \"%s\"" conf-file-name))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Compilation / Makefile generation
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; (using `compile.el')
+
+(defun vhdl-makefile-name ()
+ "Return the Makefile name of the current project or the current compiler if
+no project is defined."
+ (let ((project-alist (aget vhdl-project-alist vhdl-project))
+ (compiler-alist (aget vhdl-compiler-alist vhdl-compiler)))
+ (vhdl-replace-string
+ (cons "\\(.*\\)\n\\(.*\\)"
+ (or (nth 8 project-alist) (nth 8 compiler-alist)))
+ (concat (nth 9 compiler-alist) "\n" (nth 6 project-alist)))))
+
+(defun vhdl-compile-directory ()
+ "Return the directory where compilation/make should be run."
+ (let* ((project (aget vhdl-project-alist (vhdl-project-p t)))
+ (compiler (aget vhdl-compiler-alist vhdl-compiler))
+ (directory (vhdl-resolve-env-variable
+ (if project
+ (vhdl-replace-string
+ (cons "\\(.*\\)" (nth 5 project)) (nth 9 compiler))
+ (nth 6 compiler)))))
+ (file-name-as-directory
+ (if (file-name-absolute-p directory)
+ directory
+ (expand-file-name directory (vhdl-default-directory))))))
+
+(defun vhdl-uniquify (in-list)
+ "Remove duplicate elements from IN-LIST."
+ (let (out-list)
+ (while in-list
+ (add-to-list 'out-list (car in-list))
+ (setq in-list (cdr in-list)))
+ out-list))
+
+(defun vhdl-set-compiler (name)
+ "Set current compiler to NAME."
+ (interactive
+ (list (let ((completion-ignore-case t))
+ (completing-read "Compiler name: " vhdl-compiler-alist nil t))))
+ (if (assoc name vhdl-compiler-alist)
+ (progn (setq vhdl-compiler name)
+ (message "Current compiler: \"%s\"" vhdl-compiler))
+ (vhdl-warning (format "Unknown compiler: \"%s\"" name))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Compilation
+
+(defun vhdl-compile-init ()
+ "Initialize for compilation."
+ (when (or (null compilation-error-regexp-alist)
+ (not (assoc (car (nth 11 (car vhdl-compiler-alist)))
+ compilation-error-regexp-alist)))
+ ;; `compilation-error-regexp-alist'
+ (let ((commands-alist vhdl-compiler-alist)
+ regexp-alist sublist)
+ (while commands-alist
+ (setq sublist (nth 11 (car commands-alist)))
+ (unless (or (equal "" (car sublist))
+ (assoc (car sublist) regexp-alist))
+ (setq regexp-alist (cons (list (nth 0 sublist)
+ (if (= 0 (nth 1 sublist))
+ (if vhdl-xemacs 9 nil)
+ (nth 1 sublist))
+ (nth 2 sublist) (nth 3 sublist))
+ regexp-alist)))
+ (setq commands-alist (cdr commands-alist)))
+ (setq compilation-error-regexp-alist
+ (append compilation-error-regexp-alist (nreverse regexp-alist))))
+ ;; `compilation-file-regexp-alist'
+ (let ((commands-alist vhdl-compiler-alist)
+ regexp-alist sublist)
+ ;; matches vhdl-mode file name output
+ (setq regexp-alist '(("^Compiling \"\\(.+\\)\"" 1)))
+ (while commands-alist
+ (setq sublist (nth 12 (car commands-alist)))
+ (unless (or (equal "" (car sublist))
+ (assoc (car sublist) regexp-alist))
+ (setq regexp-alist (cons sublist regexp-alist)))
+ (setq commands-alist (cdr commands-alist)))
+ (setq compilation-file-regexp-alist
+ (append compilation-file-regexp-alist (nreverse regexp-alist))))))
+
+(defvar vhdl-compile-file-name nil
+ "Name of file to be compiled.")
+
+(defun vhdl-compile-print-file-name ()
+ "Function called within `compile' to print out file name for compilers that
+do not print any file names."
+ (insert "Compiling \"" vhdl-compile-file-name "\"\n"))
+
+(defun vhdl-get-compile-options (project compiler file-name
+ &optional file-options-only)
+ "Get compiler options. Returning nil means do not compile this file."
+ (let* ((compiler-options (nth 1 compiler))
+ (project-entry (aget (nth 4 project) vhdl-compiler))
+ (project-options (nth 0 project-entry))
+ (exception-list (and file-name (nth 2 project-entry)))
+ (work-library (vhdl-work-library))
+ (case-fold-search nil)
+ file-options)
+ (while (and exception-list
+ (not (string-match (caar exception-list) file-name)))
+ (setq exception-list (cdr exception-list)))
+ (if (and exception-list (not (cdar exception-list)))
+ nil
+ (if (and file-options-only (not exception-list))
+ 'default
+ (setq file-options (cdar exception-list))
+ ;; insert library name in compiler-specific options
+ (setq compiler-options
+ (vhdl-replace-string (cons "\\(.*\\)" compiler-options)
+ work-library))
+ ;; insert compiler-specific options in project-specific options
+ (when project-options
+ (setq project-options
+ (vhdl-replace-string
+ (cons "\\(.*\\)\n\\(.*\\)" project-options)
+ (concat work-library "\n" compiler-options))))
+ ;; insert project-specific options in file-specific options
+ (when file-options
+ (setq file-options
+ (vhdl-replace-string
+ (cons "\\(.*\\)\n\\(.*\\)\n\\(.*\\)" file-options)
+ (concat work-library "\n" compiler-options "\n"
+ project-options))))
+ ;; return options
+ (or file-options project-options compiler-options)))))
+
+(defun vhdl-get-make-options (project compiler)
+ "Get make options."
+ (let* ((compiler-options (nth 3 compiler))
+ (project-entry (aget (nth 4 project) vhdl-compiler))
+ (project-options (nth 1 project-entry))
+ (makefile-name (vhdl-makefile-name)))
+ ;; insert Makefile name in compiler-specific options
+ (setq compiler-options
+ (vhdl-replace-string (cons "\\(.*\\)" (nth 3 compiler))
+ makefile-name))
+ ;; insert compiler-specific options in project-specific options
+ (when project-options
+ (setq project-options
+ (vhdl-replace-string
+ (cons "\\(.*\\)\n\\(.*\\)" project-options)
+ (concat makefile-name "\n" compiler-options))))
+ ;; return options
+ (or project-options compiler-options)))
+
+(defun vhdl-compile ()
+ "Compile current buffer using the VHDL compiler specified in
+`vhdl-compiler'."
+ (interactive)
+ (vhdl-compile-init)
+ (let* ((project (aget vhdl-project-alist vhdl-project))
+ (compiler (or (aget vhdl-compiler-alist vhdl-compiler nil)
+ (error "ERROR: No such compiler: \"%s\"" vhdl-compiler)))
+ (command (nth 0 compiler))
+ (file-name (buffer-file-name))
+ (options (vhdl-get-compile-options project compiler file-name))
+ (default-directory (vhdl-compile-directory))
+ compilation-process-setup-function)
+ (unless (file-directory-p default-directory)
+ (error "ERROR: Compile directory does not exist: \"%s\"" default-directory))
+ ;; put file name into quotes if it contains spaces
+ (when (string-match " " file-name)
+ (setq file-name (concat "\"" file-name "\"")))
+ ;; print out file name if compiler does not
+ (setq vhdl-compile-file-name (buffer-file-name))
+ (when (and (= 0 (nth 1 (nth 10 compiler)))
+ (= 0 (nth 1 (nth 11 compiler))))
+ (setq compilation-process-setup-function 'vhdl-compile-print-file-name))
+ ;; run compilation
+ (if options
+ (when command
+ (compile (concat command " " options " " file-name)))
+ (vhdl-warning "Your project settings tell me not to compile this file"))))
+
+(defvar vhdl-make-target "all"
+ "Default target for `vhdl-make' command.")
+
+(defun vhdl-make (&optional target)
+ "Call make command for compilation of all updated source files (requires
+`Makefile'). Optional argument TARGET allows to compile the design
+specified by a target."
+ (interactive)
+ (setq vhdl-make-target
+ (or target (read-from-minibuffer "Target: " vhdl-make-target
+ vhdl-minibuffer-local-map)))
+ (vhdl-compile-init)
+ (let* ((project (aget vhdl-project-alist vhdl-project))
+ (compiler (or (aget vhdl-compiler-alist vhdl-compiler)
+ (error "ERROR: No such compiler: \"%s\"" vhdl-compiler)))
+ (command (nth 2 compiler))
+ (options (vhdl-get-make-options project compiler))
+ (default-directory (vhdl-compile-directory)))
+ (unless (file-directory-p default-directory)
+ (error "ERROR: Compile directory does not exist: \"%s\"" default-directory))
+ ;; run make
+ (compile (concat (if (equal command "") "make" command)
+ " " options " " vhdl-make-target))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Makefile generation
+
+(defun vhdl-generate-makefile ()
+ "Generate `Makefile'."
+ (interactive)
+ (let* ((compiler (or (aget vhdl-compiler-alist vhdl-compiler)
+ (error "ERROR: No such compiler: \"%s\"" vhdl-compiler)))
+ (command (nth 4 compiler)))
+ ;; generate makefile
+ (if command
+ (let ((default-directory (vhdl-compile-directory)))
+ (compile (vhdl-replace-string
+ (cons "\\(.*\\) \\(.*\\)" command)
+ (concat (vhdl-makefile-name) " " (vhdl-work-library)))))
+ (vhdl-generate-makefile-1))))
+
+(defun vhdl-get-packages (lib-alist work-library)
+ "Get packages from LIB-ALIST that belong to WORK-LIBRARY."
+ (let (pack-list)
+ (while lib-alist
+ (when (equal (downcase (caar lib-alist)) (downcase work-library))
+ (setq pack-list (cons (cdar lib-alist) pack-list)))
+ (setq lib-alist (cdr lib-alist)))
+ pack-list))
+
+(defun vhdl-generate-makefile-1 ()
+ "Generate Makefile for current project or directory."
+ ;; scan hierarchy if required
+ (if (vhdl-project-p)
+ (unless (or (assoc vhdl-project vhdl-file-alist)
+ (vhdl-load-cache vhdl-project))
+ (vhdl-scan-project-contents vhdl-project))
+ (let ((directory (abbreviate-file-name default-directory)))
+ (unless (or (assoc directory vhdl-file-alist)
+ (vhdl-load-cache directory))
+ (vhdl-scan-directory-contents directory))))
+ (let* ((directory (abbreviate-file-name (vhdl-default-directory)))
+ (project (vhdl-project-p))
+ (ent-alist (aget vhdl-entity-alist (or project directory) t))
+ (conf-alist (aget vhdl-config-alist (or project directory) t))
+ (pack-alist (aget vhdl-package-alist (or project directory) t))
+ (regexp-list (nth 12 (aget vhdl-compiler-alist vhdl-compiler)))
+ (ent-regexp (cons "\\(.*\\)" (nth 0 regexp-list)))
+ (arch-regexp (cons "\\(.*\\) \\(.*\\)" (nth 1 regexp-list)))
+ (conf-regexp (cons "\\(.*\\)" (nth 2 regexp-list)))
+ (pack-regexp (cons "\\(.*\\)" (nth 3 regexp-list)))
+ (pack-body-regexp (cons "\\(.*\\)" (nth 4 regexp-list)))
+ (adjust-case (nth 5 regexp-list))
+ (work-library (downcase (vhdl-work-library)))
+ (compile-directory (expand-file-name (vhdl-compile-directory)
+ default-directory))
+ (makefile-name (vhdl-makefile-name))
+ rule-alist arch-alist inst-alist
+ target-list depend-list unit-list prim-list second-list subcomp-list
+ lib-alist lib-body-alist pack-list all-pack-list
+ ent-key ent-file-name arch-key arch-file-name ent-arch-key
+ conf-key conf-file-name pack-key pack-file-name
+ ent-entry arch-entry conf-entry pack-entry inst-entry
+ pack-body-key pack-body-file-name inst-ent-key inst-conf-key
+ tmp-key tmp-list rule)
+ ;; check prerequisites
+ (unless (file-exists-p compile-directory)
+ (make-directory compile-directory t))
+ (unless regexp-list
+ (error "Please contact the VHDL Mode maintainer for support of \"%s\""
+ vhdl-compiler))
+ (message "Generating makefile \"%s\"..." makefile-name)
+ ;; rules for all entities
+ (setq tmp-list ent-alist)
+ (while ent-alist
+ (setq ent-entry (car ent-alist)
+ ent-key (nth 0 ent-entry))
+ (when (nth 2 ent-entry)
+ (setq ent-file-name (file-relative-name
+ (nth 2 ent-entry) compile-directory)
+ arch-alist (nth 4 ent-entry)
+ lib-alist (nth 6 ent-entry)
+ rule (aget rule-alist ent-file-name)
+ target-list (nth 0 rule)
+ depend-list (nth 1 rule)
+ second-list nil
+ subcomp-list nil)
+ (setq tmp-key (vhdl-replace-string
+ ent-regexp (funcall adjust-case ent-key)))
+ (setq unit-list (cons (cons ent-key tmp-key) unit-list))
+ ;; rule target for this entity
+ (setq target-list (cons ent-key target-list))
+ ;; rule dependencies for all used packages
+ (setq pack-list (vhdl-get-packages lib-alist work-library))
+ (setq depend-list (append depend-list pack-list))
+ (setq all-pack-list pack-list)
+ ;; add rule
+ (aput 'rule-alist ent-file-name (list target-list depend-list))
+ ;; rules for all corresponding architectures
+ (while arch-alist
+ (setq arch-entry (car arch-alist)
+ arch-key (nth 0 arch-entry)
+ ent-arch-key (concat ent-key "-" arch-key)
+ arch-file-name (file-relative-name (nth 2 arch-entry)
+ compile-directory)
+ inst-alist (nth 4 arch-entry)
+ lib-alist (nth 5 arch-entry)
+ rule (aget rule-alist arch-file-name)
+ target-list (nth 0 rule)
+ depend-list (nth 1 rule))
+ (setq tmp-key (vhdl-replace-string
+ arch-regexp
+ (funcall adjust-case (concat arch-key " " ent-key))))
+ (setq unit-list
+ (cons (cons ent-arch-key tmp-key) unit-list))
+ (setq second-list (cons ent-arch-key second-list))
+ ;; rule target for this architecture
+ (setq target-list (cons ent-arch-key target-list))
+ ;; rule dependency for corresponding entity
+ (setq depend-list (cons ent-key depend-list))
+ ;; rule dependencies for contained component instantiations
+ (while inst-alist
+ (setq inst-entry (car inst-alist))
+ (when (or (null (nth 8 inst-entry))
+ (equal (downcase (nth 8 inst-entry)) work-library))
+ (setq inst-ent-key (or (nth 7 inst-entry)
+ (nth 5 inst-entry)))
+ (setq depend-list (cons inst-ent-key depend-list)
+ subcomp-list (cons inst-ent-key subcomp-list)))
+ (setq inst-alist (cdr inst-alist)))
+ ;; rule dependencies for all used packages
+ (setq pack-list (vhdl-get-packages lib-alist work-library))
+ (setq depend-list (append depend-list pack-list))
+ (setq all-pack-list (append all-pack-list pack-list))
+ ;; add rule
+ (aput 'rule-alist arch-file-name (list target-list depend-list))
+ (setq arch-alist (cdr arch-alist)))
+ (setq prim-list (cons (list ent-key second-list
+ (append subcomp-list all-pack-list))
+ prim-list)))
+ (setq ent-alist (cdr ent-alist)))
+ (setq ent-alist tmp-list)
+ ;; rules for all configurations
+ (setq tmp-list conf-alist)
+ (while conf-alist
+ (setq conf-entry (car conf-alist)
+ conf-key (nth 0 conf-entry)
+ conf-file-name (file-relative-name
+ (nth 2 conf-entry) compile-directory)
+ ent-key (nth 4 conf-entry)
+ arch-key (nth 5 conf-entry)
+ inst-alist (nth 6 conf-entry)
+ lib-alist (nth 7 conf-entry)
+ rule (aget rule-alist conf-file-name)
+ target-list (nth 0 rule)
+ depend-list (nth 1 rule)
+ subcomp-list (list ent-key))
+ (setq tmp-key (vhdl-replace-string
+ conf-regexp (funcall adjust-case conf-key)))
+ (setq unit-list (cons (cons conf-key tmp-key) unit-list))
+ ;; rule target for this configuration
+ (setq target-list (cons conf-key target-list))
+ ;; rule dependency for corresponding entity and architecture
+ (setq depend-list
+ (cons ent-key (cons (concat ent-key "-" arch-key) depend-list)))
+ ;; rule dependencies for used packages
+ (setq pack-list (vhdl-get-packages lib-alist work-library))
+ (setq depend-list (append depend-list pack-list))
+ ;; rule dependencies for contained component configurations
+ (while inst-alist
+ (setq inst-entry (car inst-alist))
+ (setq inst-ent-key (nth 2 inst-entry)
+; comp-arch-key (nth 2 inst-entry))
+ inst-conf-key (nth 4 inst-entry))
+ (when (equal (downcase (nth 5 inst-entry)) work-library)
+ (when inst-ent-key
+ (setq depend-list (cons inst-ent-key depend-list)
+ subcomp-list (cons inst-ent-key subcomp-list)))
+; (when comp-arch-key
+; (setq depend-list (cons (concat comp-ent-key "-" comp-arch-key)
+; depend-list)))
+ (when inst-conf-key
+ (setq depend-list (cons inst-conf-key depend-list)
+ subcomp-list (cons inst-conf-key subcomp-list))))
+ (setq inst-alist (cdr inst-alist)))
+ ;; add rule
+ (aput 'rule-alist conf-file-name (list target-list depend-list))
+ (setq prim-list (cons (list conf-key nil (append subcomp-list pack-list))
+ prim-list))
+ (setq conf-alist (cdr conf-alist)))
+ (setq conf-alist tmp-list)
+ ;; rules for all packages
+ (setq tmp-list pack-alist)
+ (while pack-alist
+ (setq pack-entry (car pack-alist)
+ pack-key (nth 0 pack-entry)
+ pack-body-key nil)
+ (when (nth 2 pack-entry)
+ (setq pack-file-name (file-relative-name (nth 2 pack-entry)
+ compile-directory)
+ lib-alist (nth 6 pack-entry) lib-body-alist (nth 10 pack-entry)
+ rule (aget rule-alist pack-file-name)
+ target-list (nth 0 rule) depend-list (nth 1 rule))
+ (setq tmp-key (vhdl-replace-string
+ pack-regexp (funcall adjust-case pack-key)))
+ (setq unit-list (cons (cons pack-key tmp-key) unit-list))
+ ;; rule target for this package
+ (setq target-list (cons pack-key target-list))
+ ;; rule dependencies for all used packages
+ (setq pack-list (vhdl-get-packages lib-alist work-library))
+ (setq depend-list (append depend-list pack-list))
+ (setq all-pack-list pack-list)
+ ;; add rule
+ (aput 'rule-alist pack-file-name (list target-list depend-list))
+ ;; rules for this package's body
+ (when (nth 7 pack-entry)
+ (setq pack-body-key (concat pack-key "-body")
+ pack-body-file-name (file-relative-name (nth 7 pack-entry)
+ compile-directory)
+ rule (aget rule-alist pack-body-file-name)
+ target-list (nth 0 rule)
+ depend-list (nth 1 rule))
+ (setq tmp-key (vhdl-replace-string
+ pack-body-regexp (funcall adjust-case pack-key)))
+ (setq unit-list
+ (cons (cons pack-body-key tmp-key) unit-list))
+ ;; rule target for this package's body
+ (setq target-list (cons pack-body-key target-list))
+ ;; rule dependency for corresponding package declaration
+ (setq depend-list (cons pack-key depend-list))
+ ;; rule dependencies for all used packages
+ (setq pack-list (vhdl-get-packages lib-body-alist work-library))
+ (setq depend-list (append depend-list pack-list))
+ (setq all-pack-list (append all-pack-list pack-list))
+ ;; add rule
+ (aput 'rule-alist pack-body-file-name
+ (list target-list depend-list)))
+ (setq prim-list
+ (cons (list pack-key (when pack-body-key (list pack-body-key))
+ all-pack-list)
+ prim-list)))
+ (setq pack-alist (cdr pack-alist)))
+ (setq pack-alist tmp-list)
+ ;; generate Makefile
+ (let* ((project (aget vhdl-project-alist project))
+ (compiler (aget vhdl-compiler-alist vhdl-compiler))
+ (compiler-id (nth 9 compiler))
+ (library-directory
+ (vhdl-resolve-env-variable
+ (vhdl-replace-string
+ (cons "\\(.*\\)" (or (nth 7 project) (nth 7 compiler)))
+ compiler-id)))
+ (makefile-path-name (expand-file-name
+ makefile-name compile-directory))
+ (orig-buffer (current-buffer))
+ cell second-list subcomp-list options unit-key unit-name)
+ ;; sort lists
+ (setq unit-list (vhdl-sort-alist unit-list))
+ (setq prim-list (vhdl-sort-alist prim-list))
+ (setq tmp-list rule-alist)
+ (while tmp-list ; pre-sort rule targets
+ (setq cell (cdar tmp-list))
+ (setcar cell (sort (car cell) 'string<))
+ (setq tmp-list (cdr tmp-list)))
+ (setq rule-alist ; sort by first rule target
+ (sort rule-alist
+ (function (lambda (a b)
+ (string< (car (cadr a)) (car (cadr b)))))))
+ ;; open and clear Makefile
+ (set-buffer (find-file-noselect makefile-path-name t t))
+ (erase-buffer)
+ (insert "# -*- Makefile -*-\n"
+ "### " (file-name-nondirectory makefile-name)
+ " - VHDL Makefile generated by Emacs VHDL Mode " vhdl-version
+ "\n")
+ (if project
+ (insert "\n# Project : " (nth 0 project))
+ (insert "\n# Directory : \"" directory "\""))
+ (insert "\n# Platform : " vhdl-compiler
+ "\n# Generated : " (format-time-string "%Y-%m-%d %T ")
+ (user-login-name) "\n")
+ ;; insert compile and option variable settings
+ (insert "\n\n# Define compilation command and options\n"
+ "\nCOMPILE = " (nth 0 compiler)
+ "\nOPTIONS = " (vhdl-get-compile-options project compiler nil)
+ "\n")
+ ;; insert library paths
+ (setq library-directory
+ (directory-file-name
+ (if (file-name-absolute-p library-directory)
+ library-directory
+ (file-relative-name
+ (expand-file-name library-directory directory)
+ compile-directory))))
+ (insert "\n\n# Define library paths\n"
+ "\nLIBRARY-" work-library " = " library-directory "\n")
+ ;; insert variable definitions for all library unit files
+ (insert "\n\n# Define library unit files\n")
+ (setq tmp-list unit-list)
+ (while unit-list
+ (insert "\nUNIT-" work-library "-" (caar unit-list)
+ " = \\\n\t$(LIBRARY-" work-library ")/" (cdar unit-list))
+ (setq unit-list (cdr unit-list)))
+ ;; insert variable definition for list of all library unit files
+ (insert "\n\n\n# Define list of all library unit files\n"
+ "\nALL_UNITS =")
+ (setq unit-list tmp-list)
+ (while unit-list
+ (insert " \\\n\t" "$(UNIT-" work-library "-" (caar unit-list) ")")
+ (setq unit-list (cdr unit-list)))
+ (insert "\n")
+ (setq unit-list tmp-list)
+ ;; insert `make all' rule
+ (insert "\n\n\n# Rule for compiling entire design\n"
+ "\nall :"
+ " \\\n\t\tlibrary"
+ " \\\n\t\t$(ALL_UNITS)\n")
+ ;; insert `make clean' rule
+ (insert "\n\n# Rule for cleaning entire design\n"
+ "\nclean : "
+ "\n\t-rm -f $(ALL_UNITS)\n")
+ ;; insert `make library' rule
+ (insert "\n\n# Rule for creating library directory\n"
+ "\nlibrary :"
+ " \\\n\t\t$(LIBRARY-" work-library ")\n"
+ "\n$(LIBRARY-" work-library ") :"
+ "\n\t"
+ (vhdl-replace-string
+ (cons "\\(.*\\)\n\\(.*\\)" (nth 5 compiler))
+ (concat "$(LIBRARY-" work-library ")\n" (vhdl-work-library)))
+ "\n")
+ ;; insert rule for each library unit
+ (insert "\n\n# Rules for compiling single library units and their subhierarchy\n")
+ (while prim-list
+ (setq second-list (sort (nth 1 (car prim-list)) 'string<))
+ (setq subcomp-list
+ (sort (vhdl-uniquify (nth 2 (car prim-list))) 'string<))
+ (setq unit-key (caar prim-list)
+ unit-name (or (nth 0 (aget ent-alist unit-key t))
+ (nth 0 (aget conf-alist unit-key t))
+ (nth 0 (aget pack-alist unit-key t))))
+ (insert "\n" unit-key)
+ (unless (equal unit-key unit-name)
+ (insert " \\\n" unit-name))
+ (insert " :"
+ " \\\n\t\tlibrary"
+ " \\\n\t\t$(UNIT-" work-library "-" unit-key ")")
+ (while second-list
+ (insert " \\\n\t\t$(UNIT-" work-library "-" (car second-list) ")")
+ (setq second-list (cdr second-list)))
+ (while subcomp-list
+ (when (and (assoc (car subcomp-list) unit-list)
+ (not (equal unit-key (car subcomp-list))))
+ (insert " \\\n\t\t" (car subcomp-list)))
+ (setq subcomp-list (cdr subcomp-list)))
+ (insert "\n")
+ (setq prim-list (cdr prim-list)))
+ ;; insert rule for each library unit file
+ (insert "\n\n# Rules for compiling single library unit files\n")
+ (while rule-alist
+ (setq rule (car rule-alist))
+ ;; get compiler options for this file
+ (setq options
+ (vhdl-get-compile-options project compiler (nth 0 rule) t))
+ ;; insert rule if file is supposed to be compiled
+ (setq target-list (nth 1 rule)
+ depend-list (sort (vhdl-uniquify (nth 2 rule)) 'string<))
+ ;; insert targets
+ (setq tmp-list target-list)
+ (while target-list
+ (insert "\n$(UNIT-" work-library "-" (car target-list) ")"
+ (if (cdr target-list) " \\" " :"))
+ (setq target-list (cdr target-list)))
+ (setq target-list tmp-list)
+ ;; insert file name as first dependency
+ (insert " \\\n\t\t" (nth 0 rule))
+ ;; insert dependencies (except if also target or unit does not exist)
+ (while depend-list
+ (when (and (not (member (car depend-list) target-list))
+ (assoc (car depend-list) unit-list))
+ (insert " \\\n\t\t"
+ "$(UNIT-" work-library "-" (car depend-list) ")"))
+ (setq depend-list (cdr depend-list)))
+ ;; insert compile command
+ (if options
+ (insert "\n\t$(COMPILE) "
+ (if (eq options 'default) "$(OPTIONS)" options) " "
+ (nth 0 rule) "\n")
+ (setq tmp-list target-list)
+ (while target-list
+ (insert "\n\t@touch $(UNIT-" work-library "-" (car target-list) ")"
+ (if (cdr target-list) " \\" "\n"))
+ (setq target-list (cdr target-list)))
+ (setq target-list tmp-list))
+ (setq rule-alist (cdr rule-alist)))
+ (insert "\n\n### " makefile-name " ends here\n")
+ ;; run Makefile generation hook
+ (run-hooks 'vhdl-makefile-generation-hook)
+ (message "Generating makefile \"%s\"...done" makefile-name)
+ ;; save and close file
+ (if (file-writable-p makefile-path-name)
+ (progn (save-buffer)
+ (kill-buffer (current-buffer))
+ (set-buffer orig-buffer)
+ (add-to-history 'file-name-history makefile-path-name))
+ (vhdl-warning-when-idle
+ (format "File not writable: \"%s\""
+ (abbreviate-file-name makefile-path-name)))
+ (switch-to-buffer (current-buffer))))))
+