+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Scan functions
+
+(defun vhdl-scan-context-clause ()
+ "Scan the context clause that preceeds a design unit."
+ (let (lib-alist)
+ (save-excursion
+ (when (re-search-backward "^[ \t]*\\(architecture\\|configuration\\|entity\\|package\\)\\>" nil t)
+ (while (and (re-search-backward "^[ \t]*\\(end\\|use\\)\\>" nil t)
+ (equal "USE" (upcase (match-string 1))))
+ (when (looking-at "^[ \t]*use[ \t\n]*\\(\\w+\\)\\.\\(\\w+\\)\\.\\w+")
+ (setq lib-alist (cons (cons (match-string-no-properties 1)
+ (vhdl-match-string-downcase 2))
+ lib-alist))))))
+ lib-alist))
+
+(defun vhdl-scan-directory-contents (name &optional project update num-string
+ non-final)
+ "Scan contents of VHDL files in directory or file pattern DIR-NAME."
+ (string-match "\\(.*[/\\]\\)\\(.*\\)" name)
+; (unless (file-directory-p (match-string 1 name))
+; (message "No such directory: \"%s\"" (match-string 1 name)))
+ (let* ((dir-name (match-string 1 name))
+ (file-pattern (match-string 2 name))
+ (is-directory (= 0 (length file-pattern)))
+ (file-list
+ (if update
+ (list name)
+ (if is-directory
+ (vhdl-get-source-files t dir-name)
+ (vhdl-directory-files
+ dir-name t (wildcard-to-regexp file-pattern)))))
+ (key (or project dir-name))
+ (file-exclude-regexp
+ (or (nth 3 (aget vhdl-project-alist project)) ""))
+ (limit-design-file-size (nth 0 vhdl-speedbar-scan-limit))
+ (limit-hier-file-size (nth 0 (nth 1 vhdl-speedbar-scan-limit)))
+ (limit-hier-inst-no (nth 1 (nth 1 vhdl-speedbar-scan-limit)))
+ ent-alist conf-alist pack-alist ent-inst-list file-alist
+ tmp-list tmp-entry no-files files-exist big-files)
+ (when (or project update)
+ (setq ent-alist (aget vhdl-entity-alist key t)
+ conf-alist (aget vhdl-config-alist key t)
+ pack-alist (aget vhdl-package-alist key t)
+ ent-inst-list (car (aget vhdl-ent-inst-alist key t))
+ file-alist (aget vhdl-file-alist key t)))
+ (when (and (not is-directory) (null file-list))
+ (message "No such file: \"%s\"" name))
+ (setq files-exist file-list)
+ (when file-list
+ (setq no-files (length file-list))
+ (message "Scanning %s %s\"%s\"..."
+ (if is-directory "directory" "files") (or num-string "") name)
+ ;; exclude files
+ (unless (equal file-exclude-regexp "")
+ (let ((case-fold-search nil)
+ file-tmp-list)
+ (while file-list
+ (unless (string-match file-exclude-regexp (car file-list))
+ (setq file-tmp-list (cons (car file-list) file-tmp-list)))
+ (setq file-list (cdr file-list)))
+ (setq file-list (nreverse file-tmp-list))))
+ ;; do for all files
+ (while file-list
+ (unless noninteractive
+ (message "Scanning %s %s\"%s\"... (%2d%s)"
+ (if is-directory "directory" "files")
+ (or num-string "") name
+ (/ (* 100 (- no-files (length file-list))) no-files) "%"))
+ (let ((file-name (abbreviate-file-name (car file-list)))
+ ent-list arch-list arch-ent-list conf-list
+ pack-list pack-body-list inst-list inst-ent-list)
+ ;; scan file
+ (vhdl-visit-file
+ file-name nil
+ (vhdl-prepare-search-2
+ (save-excursion
+ ;; scan for design units
+ (if (and limit-design-file-size
+ (< limit-design-file-size (buffer-size)))
+ (progn (message "WARNING: Scan limit (design units: file size) reached in file:\n \"%s\"" file-name)
+ (setq big-files t))
+ ;; scan for entities
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*entity[ \t\n]+\\(\\w+\\)[ \t\n]+is\\>" nil t)
+ (let* ((ent-name (match-string-no-properties 1))
+ (ent-key (downcase ent-name))
+ (ent-entry (aget ent-alist ent-key t))
+ (arch-alist (nth 3 ent-entry))
+ (lib-alist (vhdl-scan-context-clause)))
+ (if (nth 1 ent-entry)
+ (vhdl-warning-when-idle
+ "Entity declared twice (used 1.): \"%s\"\n 1. in \"%s\" (line %d)\n 2. in \"%s\" (line %d)"
+ ent-name (nth 1 ent-entry) (nth 2 ent-entry)
+ file-name (vhdl-current-line))
+ (setq ent-list (cons ent-key ent-list))
+ (aput 'ent-alist ent-key
+ (list ent-name file-name (vhdl-current-line)
+ arch-alist lib-alist)))))
+ ;; scan for architectures
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*architecture[ \t\n]+\\(\\w+\\)[ \t\n]+of[ \t\n]+\\(\\w+\\)[ \t\n]+is\\>" nil t)
+ (let* ((arch-name (match-string-no-properties 1))
+ (arch-key (downcase arch-name))
+ (ent-name (match-string-no-properties 2))
+ (ent-key (downcase ent-name))
+ (ent-entry (aget ent-alist ent-key t))
+ (arch-alist (nth 3 ent-entry))
+ (arch-entry (aget arch-alist arch-key t))
+ (lib-arch-alist (vhdl-scan-context-clause)))
+ (if arch-entry
+ (vhdl-warning-when-idle
+ "Architecture declared twice (used 1.): \"%s\" of \"%s\"\n 1. in \"%s\" (line %d)\n 2. in \"%s\" (line %d)"
+ arch-name ent-name (nth 1 arch-entry)
+ (nth 2 arch-entry) file-name (vhdl-current-line))
+ (setq arch-list (cons arch-key arch-list)
+ arch-ent-list (cons ent-key arch-ent-list))
+ (aput 'arch-alist arch-key
+ (list arch-name file-name (vhdl-current-line) nil
+ lib-arch-alist))
+ (aput 'ent-alist ent-key
+ (list (or (nth 0 ent-entry) ent-name)
+ (nth 1 ent-entry) (nth 2 ent-entry)
+ (vhdl-sort-alist arch-alist)
+ (nth 4 ent-entry))))))
+ ;; scan for configurations
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*configuration[ \t\n]+\\(\\w+\\)[ \t\n]+of[ \t\n]+\\(\\w+\\)[ \t\n]+is\\>" nil t)
+ (let* ((conf-name (match-string-no-properties 1))
+ (conf-key (downcase conf-name))
+ (conf-entry (aget conf-alist conf-key t))
+ (ent-name (match-string-no-properties 2))
+ (ent-key (downcase ent-name))
+ (lib-alist (vhdl-scan-context-clause))
+ (conf-line (vhdl-current-line))
+ (end-of-unit (vhdl-get-end-of-unit))
+ arch-key comp-conf-list inst-key-list
+ inst-comp-key inst-ent-key inst-arch-key
+ inst-conf-key inst-lib-key)
+ (when (vhdl-re-search-forward "\\<for[ \t\n]+\\(\\w+\\)")
+ (setq arch-key (vhdl-match-string-downcase 1)))
+ (if conf-entry
+ (vhdl-warning-when-idle
+ "Configuration declared twice (used 1.): \"%s\" of \"%s\"\n 1. in \"%s\" (line %d)\n 2. in \"%s\" (line %d)"
+ conf-name ent-name (nth 1 conf-entry)
+ (nth 2 conf-entry) file-name conf-line)
+ (setq conf-list (cons conf-key conf-list))
+ ;; scan for subconfigurations and subentities
+ (while (re-search-forward "^[ \t]*for[ \t\n]+\\(\\w+\\([ \t\n]*,[ \t\n]*\\w+\\)*\\)[ \t\n]*:[ \t\n]*\\(\\w+\\)[ \t\n]+" end-of-unit t)
+ (setq inst-comp-key (vhdl-match-string-downcase 3)
+ inst-key-list (split-string
+ (vhdl-match-string-downcase 1)
+ "[ \t\n]*,[ \t\n]*"))
+ (vhdl-forward-syntactic-ws)
+ (when (looking-at "use[ \t\n]+\\(\\(entity\\)\\|configuration\\)[ \t\n]+\\(\\w+\\)\\.\\(\\w+\\)[ \t\n]*\\((\\(\\w+\\))\\)?")
+ (setq
+ inst-lib-key (vhdl-match-string-downcase 3)
+ inst-ent-key (and (match-string 2)
+ (vhdl-match-string-downcase 4))
+ inst-arch-key (and (match-string 2)
+ (vhdl-match-string-downcase 6))
+ inst-conf-key (and (not (match-string 2))
+ (vhdl-match-string-downcase 4)))
+ (while inst-key-list
+ (setq comp-conf-list
+ (cons (list (car inst-key-list)
+ inst-comp-key inst-ent-key
+ inst-arch-key inst-conf-key
+ inst-lib-key)
+ comp-conf-list))
+ (setq inst-key-list (cdr inst-key-list)))))
+ (aput 'conf-alist conf-key
+ (list conf-name file-name conf-line ent-key
+ arch-key comp-conf-list lib-alist)))))
+ ;; scan for packages
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*package[ \t\n]+\\(body[ \t\n]+\\)?\\(\\w+\\)[ \t\n]+is\\>" nil t)
+ (let* ((pack-name (match-string-no-properties 2))
+ (pack-key (downcase pack-name))
+ (is-body (match-string-no-properties 1))
+ (pack-entry (aget pack-alist pack-key t))
+ (pack-line (vhdl-current-line))
+ (end-of-unit (vhdl-get-end-of-unit))
+ comp-name func-name comp-alist func-alist lib-alist)
+ (if (if is-body (nth 6 pack-entry) (nth 1 pack-entry))
+ (vhdl-warning-when-idle
+ "Package%s declared twice (used 1.): \"%s\"\n 1. in \"%s\" (line %d)\n 2. in \"%s\" (line %d)"
+ (if is-body " body" "") pack-name
+ (if is-body (nth 6 pack-entry) (nth 1 pack-entry))
+ (if is-body (nth 7 pack-entry) (nth 2 pack-entry))
+ file-name (vhdl-current-line))
+ ;; scan for context clauses
+ (setq lib-alist (vhdl-scan-context-clause))
+ ;; scan for component and subprogram declarations/bodies
+ (while (re-search-forward "^[ \t]*\\(component\\|function\\|procedure\\)[ \t\n]+\\(\\w+\\|\".*\"\\)" end-of-unit t)
+ (if (equal (upcase (match-string 1)) "COMPONENT")
+ (setq comp-name (match-string-no-properties 2)
+ comp-alist
+ (cons (list (downcase comp-name) comp-name
+ file-name (vhdl-current-line))
+ comp-alist))
+ (setq func-name (match-string-no-properties 2)
+ func-alist
+ (cons (list (downcase func-name) func-name
+ file-name (vhdl-current-line))
+ func-alist))))
+ (setq func-alist (nreverse func-alist))
+ (setq comp-alist (nreverse comp-alist))
+ (if is-body
+ (setq pack-body-list (cons pack-key pack-body-list))
+ (setq pack-list (cons pack-key pack-list)))
+ (aput
+ 'pack-alist pack-key
+ (if is-body
+ (list (or (nth 0 pack-entry) pack-name)
+ (nth 1 pack-entry) (nth 2 pack-entry)
+ (nth 3 pack-entry) (nth 4 pack-entry)
+ (nth 5 pack-entry)
+ file-name pack-line func-alist lib-alist)
+ (list pack-name file-name pack-line
+ comp-alist func-alist lib-alist
+ (nth 6 pack-entry) (nth 7 pack-entry)
+ (nth 8 pack-entry) (nth 9 pack-entry))))))))
+ ;; scan for hierarchy
+ (if (and limit-hier-file-size
+ (< limit-hier-file-size (buffer-size)))
+ (progn (message "WARNING: Scan limit (hierarchy: file size) reached in file:\n \"%s\"" file-name)
+ (setq big-files t))
+ ;; scan for architectures
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*architecture[ \t\n]+\\(\\w+\\)[ \t\n]+of[ \t\n]+\\(\\w+\\)[ \t\n]+is\\>" nil t)
+ (let* ((ent-name (match-string-no-properties 2))
+ (ent-key (downcase ent-name))
+ (arch-name (match-string-no-properties 1))
+ (arch-key (downcase arch-name))
+ (ent-entry (aget ent-alist ent-key t))
+ (arch-alist (nth 3 ent-entry))
+ (arch-entry (aget arch-alist arch-key t))
+ (beg-of-unit (point))
+ (end-of-unit (vhdl-get-end-of-unit))
+ (inst-no 0)
+ inst-alist)
+ ;; scan for contained instantiations
+ (while (and (re-search-forward
+ (concat "^[ \t]*\\(\\w+\\)[ \t\n]*:[ \t\n]*\\("
+ "\\(\\w+\\)[ \t\n]+\\(--[^\n]*\n[ \t\n]*\\)*\\(generic\\|port\\)[ \t\n]+map\\>\\|"
+ "component[ \t\n]+\\(\\w+\\)\\|"
+ "\\(\\(entity\\)\\|configuration\\)[ \t\n]+\\(\\(\\w+\\)\\.\\)?\\(\\w+\\)\\([ \t\n]*(\\(\\w+\\))\\)?\\)") end-of-unit t)
+ (or (not limit-hier-inst-no)
+ (<= (setq inst-no (1+ inst-no))
+ limit-hier-inst-no)))
+ (let* ((inst-name (match-string-no-properties 1))
+ (inst-key (downcase inst-name))
+ (inst-comp-name
+ (or (match-string-no-properties 3)
+ (match-string-no-properties 6)))
+ (inst-ent-key
+ (or (and (match-string 8)
+ (vhdl-match-string-downcase 11))
+ (and inst-comp-name
+ (downcase inst-comp-name))))
+ (inst-arch-key (vhdl-match-string-downcase 13))
+ (inst-conf-key
+ (and (not (match-string 8))
+ (vhdl-match-string-downcase 11)))
+ (inst-lib-key (vhdl-match-string-downcase 10)))
+ (goto-char (match-end 1))
+ (setq inst-list (cons inst-key inst-list)
+ inst-ent-list (cons inst-ent-key inst-ent-list))
+ (setq inst-alist
+ (append
+ inst-alist
+ (list (list inst-key inst-name file-name
+ (vhdl-current-line) inst-comp-name
+ inst-ent-key inst-arch-key
+ inst-conf-key inst-lib-key))))))
+ ;; scan for contained configuration specifications
+ (goto-char beg-of-unit)
+ (while (re-search-forward
+ (concat "^[ \t]*for[ \t\n]+\\(\\w+\\([ \t\n]*,[ \t\n]*\\w+\\)*\\)[ \t\n]*:[ \t\n]*\\(\\w+\\)[ \t\n]+\\(--[^\n]*\n[ \t\n]*\\)*"
+ "use[ \t\n]+\\(\\(entity\\)\\|configuration\\)[ \t\n]+\\(\\(\\w+\\)\\.\\)?\\(\\w+\\)\\([ \t\n]*(\\(\\w+\\))\\)?") end-of-unit t)
+ (let* ((inst-comp-name (match-string-no-properties 3))
+ (inst-ent-key
+ (and (match-string 6)
+ (vhdl-match-string-downcase 9)))
+ (inst-arch-key (vhdl-match-string-downcase 11))
+ (inst-conf-key
+ (and (not (match-string 6))
+ (vhdl-match-string-downcase 9)))
+ (inst-lib-key (vhdl-match-string-downcase 8))
+ (inst-key-list
+ (split-string (vhdl-match-string-downcase 1)
+ "[ \t\n]*,[ \t\n]*"))
+ (tmp-inst-alist inst-alist)
+ inst-entry)
+ (while tmp-inst-alist
+ (when (and (or (equal "all" (car inst-key-list))
+ (member (nth 0 (car tmp-inst-alist))
+ inst-key-list))
+ (equal
+ (downcase
+ (or (nth 4 (car tmp-inst-alist)) ""))
+ (downcase inst-comp-name)))
+ (setq inst-entry (car tmp-inst-alist))
+ (setq inst-ent-list
+ (cons (or inst-ent-key (nth 5 inst-entry))
+ (vhdl-delete
+ (nth 5 inst-entry) inst-ent-list)))
+ (setq inst-entry
+ (list (nth 0 inst-entry) (nth 1 inst-entry)
+ (nth 2 inst-entry) (nth 3 inst-entry)
+ (nth 4 inst-entry)
+ (or inst-ent-key (nth 5 inst-entry))
+ (or inst-arch-key (nth 6 inst-entry))
+ inst-conf-key inst-lib-key))
+ (setcar tmp-inst-alist inst-entry))
+ (setq tmp-inst-alist (cdr tmp-inst-alist)))))
+ ;; save in cache
+ (aput 'arch-alist arch-key
+ (list (nth 0 arch-entry) (nth 1 arch-entry)
+ (nth 2 arch-entry) inst-alist
+ (nth 4 arch-entry)))
+ (aput 'ent-alist ent-key
+ (list (nth 0 ent-entry) (nth 1 ent-entry)
+ (nth 2 ent-entry) (vhdl-sort-alist arch-alist)
+ (nth 4 ent-entry)))
+ (when (and limit-hier-inst-no
+ (> inst-no limit-hier-inst-no))
+ (message "WARNING: Scan limit (hierarchy: instances per architecture) reached in file:\n \"%s\"" file-name)
+ (setq big-files t))
+ (goto-char end-of-unit))))
+ ;; remember design units for this file
+ (aput 'file-alist file-name
+ (list ent-list arch-list arch-ent-list conf-list
+ pack-list pack-body-list inst-list inst-ent-list))
+ (setq ent-inst-list (append inst-ent-list ent-inst-list))))))
+ (setq file-list (cdr file-list))))
+ (when (or (and (not project) files-exist)
+ (and project (not non-final)))
+ ;; consistency checks:
+ ;; check whether each architecture has a corresponding entity
+ (setq tmp-list ent-alist)
+ (while tmp-list
+ (when (null (nth 2 (car tmp-list)))
+ (setq tmp-entry (car (nth 4 (car tmp-list))))
+ (vhdl-warning-when-idle
+ "Architecture of non-existing entity: \"%s\" of \"%s\"\n in \"%s\" (line %d)"
+ (nth 1 tmp-entry) (nth 1 (car tmp-list)) (nth 2 tmp-entry)
+ (nth 3 tmp-entry)))
+ (setq tmp-list (cdr tmp-list)))
+ ;; check whether configuration has a corresponding entity/architecture
+ (setq tmp-list conf-alist)
+ (while tmp-list
+ (if (setq tmp-entry (aget ent-alist (nth 4 (car tmp-list)) t))
+ (unless (aget (nth 3 tmp-entry) (nth 5 (car tmp-list)) t)
+ (setq tmp-entry (car tmp-list))
+ (vhdl-warning-when-idle
+ "Configuration of non-existing architecture: \"%s\" of \"%s(%s)\"\n in \"%s\" (line %d)"
+ (nth 1 tmp-entry) (nth 4 tmp-entry) (nth 5 tmp-entry)
+ (nth 2 tmp-entry) (nth 3 tmp-entry)))
+ (setq tmp-entry (car tmp-list))
+ (vhdl-warning-when-idle
+ "Configuration of non-existing entity: \"%s\" of \"%s\"\n in \"%s\" (line %d)"
+ (nth 1 tmp-entry) (nth 4 tmp-entry)
+ (nth 2 tmp-entry) (nth 3 tmp-entry)))
+ (setq tmp-list (cdr tmp-list)))
+ ;; check whether each package body has a package declaration
+ (setq tmp-list pack-alist)
+ (while tmp-list
+ (when (null (nth 2 (car tmp-list)))
+ (setq tmp-entry (car tmp-list))
+ (vhdl-warning-when-idle
+ "Package body of non-existing package: \"%s\"\n in \"%s\" (line %d)"
+ (nth 1 tmp-entry) (nth 7 tmp-entry) (nth 8 tmp-entry)))
+ (setq tmp-list (cdr tmp-list)))
+ ;; sort lists
+ (setq ent-alist (vhdl-sort-alist ent-alist))
+ (setq conf-alist (vhdl-sort-alist conf-alist))
+ (setq pack-alist (vhdl-sort-alist pack-alist))
+ ;; remember updated directory/project
+ (add-to-list 'vhdl-updated-project-list (or project dir-name)))
+ ;; clear directory alists
+ (unless project
+ (adelete 'vhdl-entity-alist key)
+ (adelete 'vhdl-config-alist key)
+ (adelete 'vhdl-package-alist key)
+ (adelete 'vhdl-ent-inst-alist key)
+ (adelete 'vhdl-file-alist key))
+ ;; put directory contents into cache
+ (aput 'vhdl-entity-alist key ent-alist)
+ (aput 'vhdl-config-alist key conf-alist)
+ (aput 'vhdl-package-alist key pack-alist)
+ (aput 'vhdl-ent-inst-alist key (list ent-inst-list))
+ (aput 'vhdl-file-alist key file-alist)
+ ;; final messages
+ (message "Scanning %s %s\"%s\"...done"
+ (if is-directory "directory" "files") (or num-string "") name)
+ (unless project (message "Scanning directory...done"))
+ (when big-files
+ (vhdl-warning-when-idle "Scanning is incomplete.\n --> see user option `vhdl-speedbar-scan-limit'"))
+ ;; save cache when scanned non-interactively
+ (when (or (not project) (not non-final))
+ (when (and noninteractive vhdl-speedbar-save-cache)
+ (vhdl-save-cache key)))
+ t))
+
+(defun vhdl-scan-project-contents (project)
+ "Scan the contents of all VHDL files found in the directories and files
+of PROJECT."
+ (let ((dir-list (or (nth 2 (aget vhdl-project-alist project)) '("")))
+ (default-dir (vhdl-resolve-env-variable
+ (nth 1 (aget vhdl-project-alist project))))
+ (file-exclude-regexp
+ (or (nth 3 (aget vhdl-project-alist project)) ""))
+ dir-list-tmp dir dir-name num-dir act-dir recursive)
+ ;; clear project alists
+ (adelete 'vhdl-entity-alist project)
+ (adelete 'vhdl-config-alist project)
+ (adelete 'vhdl-package-alist project)
+ (adelete 'vhdl-ent-inst-alist project)
+ (adelete 'vhdl-file-alist project)
+ ;; expand directory names by default-directory
+ (message "Collecting source files...")
+ (while dir-list
+ (setq dir (vhdl-resolve-env-variable (car dir-list)))
+ (string-match "\\(\\(-r \\)?\\)\\(.*\\)" dir)
+ (setq recursive (match-string 1 dir)
+ dir-name (match-string 3 dir))
+ (setq dir-list-tmp
+ (cons (concat recursive
+ (if (file-name-absolute-p dir-name) "" default-dir)
+ dir-name)
+ dir-list-tmp))
+ (setq dir-list (cdr dir-list)))
+ ;; resolve path wildcards
+ (setq dir-list-tmp (vhdl-resolve-paths dir-list-tmp))
+ ;; expand directories
+ (while dir-list-tmp
+ (setq dir (car dir-list-tmp))
+ ;; get subdirectories
+ (if (string-match "-r \\(.*[/\\]\\)" dir)
+ (setq dir-list (append dir-list (vhdl-get-subdirs
+ (match-string 1 dir))))
+ (setq dir-list (append dir-list (list dir))))
+ (setq dir-list-tmp (cdr dir-list-tmp)))
+ ;; exclude files
+ (unless (equal file-exclude-regexp "")
+ (let ((case-fold-search nil))
+ (while dir-list
+ (unless (string-match file-exclude-regexp (car dir-list))
+ (setq dir-list-tmp (cons (car dir-list) dir-list-tmp)))
+ (setq dir-list (cdr dir-list)))
+ (setq dir-list (nreverse dir-list-tmp))))
+ (message "Collecting source files...done")
+ ;; scan for design units for each directory in DIR-LIST
+ (setq dir-list-tmp nil
+ num-dir (length dir-list)
+ act-dir 1)
+ (while dir-list
+ (setq dir-name (abbreviate-file-name
+ (expand-file-name (car dir-list))))
+ (vhdl-scan-directory-contents dir-name project nil
+ (format "(%s/%s) " act-dir num-dir)
+ (cdr dir-list))
+ (add-to-list 'dir-list-tmp (file-name-directory dir-name))
+ (setq dir-list (cdr dir-list)
+ act-dir (1+ act-dir)))
+ (aput 'vhdl-directory-alist project (list (nreverse dir-list-tmp)))
+ (message "Scanning project \"%s\"...done" project)))
+
+(defun vhdl-update-file-contents (file-name)
+ "Update hierarchy information by contents of current buffer."
+ (setq file-name (abbreviate-file-name file-name))
+ (let* ((dir-name (file-name-directory file-name))
+ (directory-alist vhdl-directory-alist)
+ updated)
+ (while directory-alist
+ (when (member dir-name (nth 1 (car directory-alist)))
+ (let* ((vhdl-project (nth 0 (car directory-alist)))
+ (project (vhdl-project-p))
+ (ent-alist (aget vhdl-entity-alist (or project dir-name) t))
+ (conf-alist (aget vhdl-config-alist (or project dir-name) t))
+ (pack-alist (aget vhdl-package-alist (or project dir-name) t))
+ (ent-inst-list (car (aget vhdl-ent-inst-alist
+ (or project dir-name) t)))
+ (file-alist (aget vhdl-file-alist (or project dir-name) t))
+ (file-entry (aget file-alist file-name t))
+ (ent-list (nth 0 file-entry))
+ (arch-list (nth 1 file-entry))
+ (arch-ent-list (nth 2 file-entry))
+ (conf-list (nth 3 file-entry))
+ (pack-list (nth 4 file-entry))
+ (pack-body-list (nth 5 file-entry))
+ (inst-ent-list (nth 7 file-entry))
+ (cache-key (or project dir-name))
+ arch-alist key ent-key entry)
+ ;; delete design units previously contained in this file:
+ ;; entities
+ (while ent-list
+ (setq key (car ent-list)
+ entry (aget ent-alist key t))
+ (when (equal file-name (nth 1 entry))
+ (if (nth 3 entry)
+ (aput 'ent-alist key
+ (list (nth 0 entry) nil nil (nth 3 entry) nil))
+ (adelete 'ent-alist key)))
+ (setq ent-list (cdr ent-list)))
+ ;; architectures
+ (while arch-list
+ (setq key (car arch-list)
+ ent-key (car arch-ent-list)
+ entry (aget ent-alist ent-key t)
+ arch-alist (nth 3 entry))
+ (when (equal file-name (nth 1 (aget arch-alist key t)))
+ (adelete 'arch-alist key)
+ (if (or (nth 1 entry) arch-alist)
+ (aput 'ent-alist ent-key
+ (list (nth 0 entry) (nth 1 entry) (nth 2 entry)
+ arch-alist (nth 4 entry)))
+ (adelete 'ent-alist ent-key)))
+ (setq arch-list (cdr arch-list)
+ arch-ent-list (cdr arch-ent-list)))
+ ;; configurations
+ (while conf-list
+ (setq key (car conf-list))
+ (when (equal file-name (nth 1 (aget conf-alist key t)))
+ (adelete 'conf-alist key))
+ (setq conf-list (cdr conf-list)))
+ ;; package declarations
+ (while pack-list
+ (setq key (car pack-list)
+ entry (aget pack-alist key t))
+ (when (equal file-name (nth 1 entry))
+ (if (nth 6 entry)
+ (aput 'pack-alist key
+ (list (nth 0 entry) nil nil nil nil nil
+ (nth 6 entry) (nth 7 entry) (nth 8 entry)
+ (nth 9 entry)))
+ (adelete 'pack-alist key)))
+ (setq pack-list (cdr pack-list)))
+ ;; package bodies
+ (while pack-body-list
+ (setq key (car pack-body-list)
+ entry (aget pack-alist key t))
+ (when (equal file-name (nth 6 entry))
+ (if (nth 1 entry)
+ (aput 'pack-alist key
+ (list (nth 0 entry) (nth 1 entry) (nth 2 entry)
+ (nth 3 entry) (nth 4 entry) (nth 5 entry)
+ nil nil nil nil))
+ (adelete 'pack-alist key)))
+ (setq pack-body-list (cdr pack-body-list)))
+ ;; instantiated entities
+ (while inst-ent-list
+ (setq ent-inst-list
+ (vhdl-delete (car inst-ent-list) ent-inst-list))
+ (setq inst-ent-list (cdr inst-ent-list)))
+ ;; update caches
+ (vhdl-aput 'vhdl-entity-alist cache-key ent-alist)
+ (vhdl-aput 'vhdl-config-alist cache-key conf-alist)
+ (vhdl-aput 'vhdl-package-alist cache-key pack-alist)
+ (vhdl-aput 'vhdl-ent-inst-alist cache-key (list ent-inst-list))
+ ;; scan file
+ (vhdl-scan-directory-contents file-name project t)
+ (when (or (and vhdl-speedbar-show-projects project)
+ (and (not vhdl-speedbar-show-projects) (not project)))
+ (vhdl-speedbar-refresh project))
+ (setq updated t)))
+ (setq directory-alist (cdr directory-alist)))
+ updated))
+
+(defun vhdl-update-hierarchy ()
+ "Update directory and hierarchy information in speedbar."
+ (let ((file-list (reverse vhdl-modified-file-list))
+ updated)
+ (when (and vhdl-speedbar-update-on-saving file-list)
+ (while file-list
+ (setq updated
+ (or (vhdl-update-file-contents (car file-list))
+ updated))
+ (setq file-list (cdr file-list)))
+ (setq vhdl-modified-file-list nil)
+ (when updated (message "Updating hierarchy...done")))))
+
+;; structure (parenthesised expression means list of such entries)
+;; (inst-key inst-file-marker comp-ent-key comp-ent-file-marker
+;; comp-arch-key comp-arch-file-marker comp-conf-key comp-conf-file-marker
+;; comp-lib-name level)
+(defun vhdl-get-hierarchy (ent-alist conf-alist ent-key arch-key conf-key
+ conf-inst-alist level indent
+ &optional include-top ent-hier)
+ "Get instantiation hierarchy beginning in architecture ARCH-KEY of
+entity ENT-KEY."
+ (let* ((ent-entry (aget ent-alist ent-key t))
+ (arch-entry (if arch-key (aget (nth 3 ent-entry) arch-key t)
+ (cdar (last (nth 3 ent-entry)))))
+ (inst-alist (nth 3 arch-entry))
+ inst-entry inst-ent-entry inst-arch-entry inst-conf-entry comp-entry
+ hier-list subcomp-list tmp-list inst-key inst-comp-name
+ inst-ent-key inst-arch-key inst-conf-key inst-lib-key)
+ (when (= level 0) (message "Extract design hierarchy..."))
+ (when include-top
+ (setq level (1+ level)))
+ (when (member ent-key ent-hier)
+ (error "ERROR: Instantiation loop detected, component instantiates itself: \"%s\"" ent-key))
+ ;; check configured architecture (already checked during scanning)
+; (unless (or (null conf-inst-alist) (assoc arch-key (nth 3 ent-entry)))
+; (vhdl-warning-when-idle "Configuration for non-existing architecture used: \"%s\"" conf-key))
+ ;; process all instances
+ (while inst-alist
+ (setq inst-entry (car inst-alist)
+ inst-key (nth 0 inst-entry)
+ inst-comp-name (nth 4 inst-entry)
+ inst-conf-key (nth 7 inst-entry))
+ ;; search entry in configuration's instantiations list
+ (setq tmp-list conf-inst-alist)
+ (while (and tmp-list
+ (not (and (member (nth 0 (car tmp-list))
+ (list "all" inst-key))
+ (equal (nth 1 (car tmp-list))
+ (downcase (or inst-comp-name ""))))))
+ (setq tmp-list (cdr tmp-list)))
+ (setq inst-conf-key (or (nth 4 (car tmp-list)) inst-conf-key))
+ (setq inst-conf-entry (aget conf-alist inst-conf-key t))
+ (when (and inst-conf-key (not inst-conf-entry))
+ (vhdl-warning-when-idle "Configuration not found: \"%s\"" inst-conf-key))
+ ;; determine entity
+ (setq inst-ent-key
+ (or (nth 2 (car tmp-list)) ; from configuration
+ (nth 3 inst-conf-entry) ; from subconfiguration
+ (nth 3 (aget conf-alist (nth 7 inst-entry) t))
+ ; from configuration spec.
+ (nth 5 inst-entry))) ; from direct instantiation
+ (setq inst-ent-entry (aget ent-alist inst-ent-key t))
+ ;; determine architecture
+ (setq inst-arch-key
+ (or (nth 3 (car tmp-list)) ; from configuration
+ (nth 4 inst-conf-entry) ; from subconfiguration
+ (nth 6 inst-entry) ; from direct instantiation
+ (nth 4 (aget conf-alist (nth 7 inst-entry)))
+ ; from configuration spec.
+ (caar (nth 3 inst-ent-entry)))) ; random (simplified MRA)
+ (setq inst-arch-entry (aget (nth 3 inst-ent-entry) inst-arch-key t))
+ ;; set library
+ (setq inst-lib-key
+ (or (nth 5 (car tmp-list)) ; from configuration
+ (nth 8 inst-entry))) ; from direct instantiation
+ ;; gather information for this instance
+ (setq comp-entry
+ (list (nth 1 inst-entry)
+ (cons (nth 2 inst-entry) (nth 3 inst-entry))
+ (or (nth 0 inst-ent-entry) (nth 4 inst-entry))
+ (cons (nth 1 inst-ent-entry) (nth 2 inst-ent-entry))
+ (or (nth 0 inst-arch-entry) inst-arch-key)
+ (cons (nth 1 inst-arch-entry) (nth 2 inst-arch-entry))
+ (or (nth 0 inst-conf-entry) inst-conf-key)
+ (cons (nth 1 inst-conf-entry) (nth 2 inst-conf-entry))
+ inst-lib-key level))
+ ;; get subcomponent hierarchy
+ (setq subcomp-list (vhdl-get-hierarchy
+ ent-alist conf-alist
+ inst-ent-key inst-arch-key inst-conf-key
+ (nth 5 inst-conf-entry)
+ (1+ level) indent nil (cons ent-key ent-hier)))
+ ;; add to list
+ (setq hier-list (append hier-list (list comp-entry) subcomp-list))
+ (setq inst-alist (cdr inst-alist)))
+ (when include-top
+ (setq hier-list
+ (cons (list nil nil (nth 0 ent-entry)
+ (cons (nth 1 ent-entry) (nth 2 ent-entry))
+ (nth 0 arch-entry)
+ (cons (nth 1 arch-entry) (nth 2 arch-entry))
+ nil nil
+ nil (1- level))
+ hier-list)))
+ (when (or (= level 0) (and include-top (= level 1))) (message ""))
+ hier-list))
+
+(defun vhdl-get-instantiations (ent-key indent)
+ "Get all instantiations of entity ENT-KEY."
+ (let ((ent-alist (aget vhdl-entity-alist (vhdl-speedbar-line-key indent) t))
+ arch-alist inst-alist ent-inst-list
+ ent-entry arch-entry inst-entry)
+ (while ent-alist
+ (setq ent-entry (car ent-alist))
+ (setq arch-alist (nth 4 ent-entry))
+ (while arch-alist
+ (setq arch-entry (car arch-alist))
+ (setq inst-alist (nth 4 arch-entry))
+ (while inst-alist
+ (setq inst-entry (car inst-alist))
+ (when (equal ent-key (nth 5 inst-entry))
+ (setq ent-inst-list
+ (cons (list (nth 1 inst-entry)
+ (cons (nth 2 inst-entry) (nth 3 inst-entry))
+ (nth 1 ent-entry)
+ (cons (nth 2 ent-entry) (nth 3 ent-entry))
+ (nth 1 arch-entry)
+ (cons (nth 2 arch-entry) (nth 3 arch-entry)))
+ ent-inst-list)))
+ (setq inst-alist (cdr inst-alist)))
+ (setq arch-alist (cdr arch-alist)))
+ (setq ent-alist (cdr ent-alist)))
+ (nreverse ent-inst-list)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Caching in file
+
+(defun vhdl-save-caches ()
+ "Save all updated hierarchy caches to file."
+ (interactive)
+ (condition-case nil
+ (when vhdl-speedbar-save-cache
+ ;; update hierarchy
+ (vhdl-update-hierarchy)
+ (let ((project-list vhdl-updated-project-list))
+ (message "Saving hierarchy caches...")
+ ;; write updated project caches
+ (while project-list
+ (vhdl-save-cache (car project-list))
+ (setq project-list (cdr project-list)))
+ (message "Saving hierarchy caches...done")))
+ (error (progn (vhdl-warning "ERROR: An error occured while saving the hierarchy caches")
+ (sit-for 2)))))
+
+(defun vhdl-save-cache (key)
+ "Save current hierarchy cache to file."
+ (let* ((orig-buffer (current-buffer))
+ (vhdl-project key)
+ (project (vhdl-project-p))
+ (default-directory key)
+ (directory (abbreviate-file-name (vhdl-default-directory)))
+ (file-name (vhdl-resolve-env-variable
+ (vhdl-replace-string
+ (cons "\\(.*\\) \\(.*\\)" vhdl-speedbar-cache-file-name)
+ (concat
+ (subst-char-in-string ? ?_ (or project "dir"))
+ " " (user-login-name)))))
+ (file-dir-name (expand-file-name file-name directory))
+ (cache-key (or project directory))
+ (key (if project "project" "directory")))
+ (unless (file-exists-p (file-name-directory file-dir-name))
+ (make-directory (file-name-directory file-dir-name) t))
+ (if (not (file-writable-p file-dir-name))
+ (progn (vhdl-warning (format "File not writable: \"%s\""
+ (abbreviate-file-name file-dir-name)))
+ (sit-for 2))
+ (message "Saving cache: \"%s\"" file-dir-name)
+ (set-buffer (find-file-noselect file-dir-name t t))
+ (erase-buffer)
+ (insert ";; -*- Emacs-Lisp -*-\n\n"
+ ";;; " (file-name-nondirectory file-name)
+ " - design hierarchy cache file for Emacs VHDL Mode "
+ vhdl-version "\n")
+ (insert "\n;; " (if project "Project " "Directory") " : ")
+ (if project (insert project) (prin1 directory (current-buffer)))
+ (insert "\n;; Saved : " (format-time-string "%Y-%m-%d %T ")
+ (user-login-name) "\n\n"
+ "\n;; version number\n"
+ "(setq vhdl-cache-version \"" vhdl-version "\")\n"
+ "\n;; " (if project "project" "directory") " name"
+ "\n(setq " key " ")
+ (prin1 (or project directory) (current-buffer))
+ (insert ")\n")
+ (when (member 'hierarchy vhdl-speedbar-save-cache)
+ (insert "\n;; entity and architecture cache\n"
+ "(aput 'vhdl-entity-alist " key " '")
+ (print (aget vhdl-entity-alist cache-key t) (current-buffer))
+ (insert ")\n\n;; configuration cache\n"
+ "(aput 'vhdl-config-alist " key " '")
+ (print (aget vhdl-config-alist cache-key t) (current-buffer))
+ (insert ")\n\n;; package cache\n"
+ "(aput 'vhdl-package-alist " key " '")
+ (print (aget vhdl-package-alist cache-key t) (current-buffer))
+ (insert ")\n\n;; instantiated entities cache\n"
+ "(aput 'vhdl-ent-inst-alist " key " '")
+ (print (aget vhdl-ent-inst-alist cache-key t) (current-buffer))
+ (insert ")\n\n;; design units per file cache\n"
+ "(aput 'vhdl-file-alist " key " '")
+ (print (aget vhdl-file-alist cache-key t) (current-buffer))
+ (when project
+ (insert ")\n\n;; source directories in project cache\n"
+ "(aput 'vhdl-directory-alist " key " '")
+ (print (aget vhdl-directory-alist cache-key t) (current-buffer)))
+ (insert ")\n"))
+ (when (member 'display vhdl-speedbar-save-cache)
+ (insert "\n;; shown design units cache\n"
+ "(aput 'vhdl-speedbar-shown-unit-alist " key " '")
+ (print (aget vhdl-speedbar-shown-unit-alist cache-key t)
+ (current-buffer))
+ (insert ")\n"))
+ (setq vhdl-updated-project-list
+ (delete cache-key vhdl-updated-project-list))
+ (save-buffer)
+ (kill-buffer (current-buffer))
+ (set-buffer orig-buffer))))
+
+(defun vhdl-load-cache (key)
+ "Load hierarchy cache information from file."
+ (let* ((vhdl-project key)
+ (default-directory key)
+ (directory (vhdl-default-directory))
+ (file-name (vhdl-resolve-env-variable
+ (vhdl-replace-string
+ (cons "\\(.*\\) \\(.*\\)" vhdl-speedbar-cache-file-name)
+ (concat
+ (subst-char-in-string ? ?_ (or (vhdl-project-p) "dir"))
+ " " (user-login-name)))))
+ (file-dir-name (expand-file-name file-name directory))
+ vhdl-cache-version)
+ (unless (memq 'vhdl-save-caches kill-emacs-hook)
+ (add-hook 'kill-emacs-hook 'vhdl-save-caches))
+ (when (file-exists-p file-dir-name)
+ (condition-case ()
+ (progn (load-file file-dir-name)
+ (string< (mapconcat
+ (lambda (a) (format "%3d" (string-to-int a)))
+ (split-string "3.31.14" "\\.") "")
+ (mapconcat
+ (lambda (a) (format "%3d" (string-to-int a)))
+ (split-string vhdl-cache-version "\\.") "")))
+ (error (progn (vhdl-warning (format "ERROR: Corrupted cache file: \"%s\"" file-dir-name))
+ nil))))))
+
+(defun vhdl-require-hierarchy-info ()
+ "Make sure that hierarchy information is available. Load cache or scan files
+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)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Add hierarchy browser functionality to speedbar
+
+(defvar vhdl-speedbar-key-map nil
+ "Keymap used when in the VHDL hierarchy browser mode.")
+
+(defvar vhdl-speedbar-menu-items nil
+ "Additional menu-items to add to speedbar frame.")
+
+(defun vhdl-speedbar-initialize ()
+ "Initialize speedbar."
+ ;; general settings
+; (set (make-local-variable 'speedbar-tag-hierarchy-method) nil)
+ ;; VHDL file extensions (extracted from `auto-mode-alist')
+ (let ((mode-alist auto-mode-alist))
+ (while mode-alist
+ (when (eq (cdar mode-alist) 'vhdl-mode)
+ (speedbar-add-supported-extension (caar mode-alist)))
+ (setq mode-alist (cdr mode-alist))))
+ ;; hierarchy browser settings
+ (when (boundp 'speedbar-mode-functions-list)
+ ;; special functions
+ (speedbar-add-mode-functions-list
+ '("vhdl directory"
+ (speedbar-item-info . vhdl-speedbar-item-info)
+ (speedbar-line-path . speedbar-files-line-path)))
+ (speedbar-add-mode-functions-list
+ '("vhdl project"
+ (speedbar-item-info . vhdl-speedbar-item-info)
+ (speedbar-line-path . vhdl-speedbar-line-project)))
+ ;; keymap
+ (unless vhdl-speedbar-key-map
+ (setq vhdl-speedbar-key-map (speedbar-make-specialized-keymap))
+ (define-key vhdl-speedbar-key-map "e" 'speedbar-edit-line)
+ (define-key vhdl-speedbar-key-map "\C-m" 'speedbar-edit-line)
+ (define-key vhdl-speedbar-key-map "+" 'speedbar-expand-line)
+ (define-key vhdl-speedbar-key-map "=" 'speedbar-expand-line)
+ (define-key vhdl-speedbar-key-map "-" 'vhdl-speedbar-contract-level)
+ (define-key vhdl-speedbar-key-map "_" 'vhdl-speedbar-contract-all)
+ (define-key vhdl-speedbar-key-map "C" 'vhdl-speedbar-port-copy)
+ (define-key vhdl-speedbar-key-map "P" 'vhdl-speedbar-place-component)
+ (define-key vhdl-speedbar-key-map "K" 'vhdl-speedbar-make-design)
+ (define-key vhdl-speedbar-key-map "R" 'vhdl-speedbar-rescan-hierarchy)
+ (define-key vhdl-speedbar-key-map "S" 'vhdl-save-caches)
+ (let ((key 0))
+ (while (<= key 9)
+ (define-key vhdl-speedbar-key-map (int-to-string key)
+ `(lambda () (interactive) (vhdl-speedbar-set-depth ,key)))
+ (setq key (1+ key)))))
+ (define-key speedbar-key-map "h"
+ (lambda () (interactive)
+ (speedbar-change-initial-expansion-list "vhdl directory")))
+ (define-key speedbar-key-map "H"
+ (lambda () (interactive)
+ (speedbar-change-initial-expansion-list "vhdl project")))
+ ;; menu
+ (unless vhdl-speedbar-menu-items
+ (setq
+ vhdl-speedbar-menu-items
+ `(["Edit" speedbar-edit-line t]
+ ["Expand" speedbar-expand-line
+ (save-excursion (beginning-of-line) (looking-at "[0-9]+: *.\\+. "))]
+ ["Contract" vhdl-speedbar-contract-level t]
+ ["Expand All" vhdl-speedbar-expand-all t]
+ ["Contract All" vhdl-speedbar-contract-all t]
+ ,(let ((key 0) (menu-list '("Hierarchy Depth")))
+ (while (<= key 9)
+ (setq menu-list
+ (cons `[,(if (= key 0) "All" (int-to-string key))
+ (vhdl-speedbar-set-depth ,key)
+ :style radio
+ :selected (= vhdl-speedbar-hierarchy-depth ,key)
+ :keys ,(int-to-string key)]
+ menu-list))
+ (setq key (1+ key)))
+ (nreverse menu-list))
+ "--"
+ ["Copy Port/Subprogram" vhdl-speedbar-port-copy
+ (or (vhdl-speedbar-check-unit 'entity)
+ (vhdl-speedbar-check-unit 'subprogram))]
+ ["Place Component" vhdl-speedbar-place-component
+ (vhdl-speedbar-check-unit 'entity)]
+ ["Make" vhdl-speedbar-make-design
+ (save-excursion (beginning-of-line) (looking-at "[0-9]+: *[[<]"))]
+ ["Generate Makefile" vhdl-speedbar-generate-makefile
+ (save-excursion (beginning-of-line) (looking-at "[0-9]+:"))]
+ ["Rescan Directory" vhdl-speedbar-rescan-hierarchy
+ :active (save-excursion (beginning-of-line) (looking-at "[0-9]+:"))
+ ,(if vhdl-xemacs :active :visible) (not vhdl-speedbar-show-projects)]
+ ["Rescan Project" vhdl-speedbar-rescan-hierarchy
+ :active (save-excursion (beginning-of-line) (looking-at "[0-9]+:"))
+ ,(if vhdl-xemacs :active :visible) vhdl-speedbar-show-projects]
+ ["Save Caches" vhdl-save-caches vhdl-updated-project-list])))
+ ;; hook-ups
+ (speedbar-add-expansion-list
+ '("vhdl directory" vhdl-speedbar-menu-items vhdl-speedbar-key-map
+ vhdl-speedbar-display-directory))
+ (speedbar-add-expansion-list
+ '("vhdl project" vhdl-speedbar-menu-items vhdl-speedbar-key-map
+ vhdl-speedbar-display-projects))
+ (setq speedbar-stealthy-function-list
+ (append
+ '(("vhdl directory" vhdl-speedbar-update-current-unit)
+ ("vhdl project" vhdl-speedbar-update-current-project
+ vhdl-speedbar-update-current-unit)
+; ("files" (lambda () (setq speedbar-ignored-path-regexp
+; (speedbar-extension-list-to-regex
+; speedbar-ignored-path-expressions))))
+ )
+ speedbar-stealthy-function-list))
+ (when (eq vhdl-speedbar-display-mode 'directory)
+ (setq speedbar-initial-expansion-list-name "vhdl directory"))
+ (when (eq vhdl-speedbar-display-mode 'project)
+ (setq speedbar-initial-expansion-list-name "vhdl project"))
+ (add-hook 'speedbar-timer-hook 'vhdl-update-hierarchy)))
+
+(defun vhdl-speedbar (&optional arg)
+ "Open/close speedbar."
+ (interactive)
+ (if (not (fboundp 'speedbar))
+ (error "WARNING: Speedbar is not available or not installed")
+ (condition-case ()
+ (speedbar-frame-mode arg)
+ (error (error "WARNING: An error occurred while opening speedbar")))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Display functions
+
+(defvar vhdl-speedbar-last-selected-project nil
+ "Name of last selected project.")
+
+;; macros must be defined in the file they are used (copied from `speedbar.el')
+(defmacro speedbar-with-writable (&rest forms)
+ "Allow the buffer to be writable and evaluate FORMS."
+ (list 'let '((inhibit-read-only t))
+ (cons 'progn forms)))
+(put 'speedbar-with-writable 'lisp-indent-function 0)
+
+(defun vhdl-speedbar-display-directory (directory depth &optional rescan)
+ "Display directory and hierarchy information in speedbar."
+ (setq vhdl-speedbar-show-projects nil)
+ (setq speedbar-ignored-path-regexp
+ (speedbar-extension-list-to-regex speedbar-ignored-path-expressions))
+ (setq directory (abbreviate-file-name (file-name-as-directory directory)))
+ (setq speedbar-last-selected-file nil)
+ (speedbar-with-writable
+ (condition-case nil
+ (progn
+ ;; insert directory path
+ (speedbar-directory-buttons directory depth)
+ ;; insert subdirectories
+ (vhdl-speedbar-insert-dirs (speedbar-file-lists directory) depth)
+ ;; scan and insert hierarchy of current directory
+ (vhdl-speedbar-insert-dir-hierarchy directory depth
+ speedbar-power-click)
+ ;; expand subdirectories
+ (when (= depth 0) (vhdl-speedbar-expand-dirs directory)))
+ (error (vhdl-warning-when-idle "ERROR: Invalid hierarchy information, unable to display correctly")))))
+
+(defun vhdl-speedbar-display-projects (project depth &optional rescan)
+ "Display projects and hierarchy information in speedbar."
+ (setq vhdl-speedbar-show-projects t)
+ (setq speedbar-ignored-path-regexp ".")
+ (setq speedbar-last-selected-file nil)
+ (setq vhdl-speedbar-last-selected-project nil)
+ (speedbar-with-writable
+ (condition-case nil
+ ;; insert projects
+ (vhdl-speedbar-insert-projects)
+ (error (vhdl-warning-when-idle "ERROR: Invalid hierarchy information, unable to display correctly"))))
+ (setq speedbar-full-text-cache nil)) ; prevent caching
+
+(defun vhdl-speedbar-insert-projects ()
+ "Insert all projects in speedbar."
+ (vhdl-speedbar-make-title-line "Projects:")
+ (let ((project-alist (if vhdl-project-sort
+ (vhdl-sort-alist (copy-alist vhdl-project-alist))
+ vhdl-project-alist))
+ (vhdl-speedbar-update-current-unit nil))
+ ;; insert projects
+ (while project-alist
+ (speedbar-make-tag-line
+ 'angle ?+ 'vhdl-speedbar-expand-project
+ (caar project-alist) (caar project-alist)
+ 'vhdl-toggle-project (caar project-alist) 'speedbar-directory-face 0)
+ (setq project-alist (cdr project-alist)))
+ (setq project-alist vhdl-project-alist)
+ ;; expand projects
+ (while project-alist
+ (when (member (caar project-alist) vhdl-speedbar-shown-project-list)
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^\\([0-9]+:\\s-*<\\)[+]>\\s-+" (caar project-alist) "$") nil t)
+ (goto-char (match-end 1))
+ (speedbar-do-function-pointer)))
+ (setq project-alist (cdr project-alist))))
+; (vhdl-speedbar-update-current-project)
+; (vhdl-speedbar-update-current-unit nil t)
+ )
+
+(defun vhdl-speedbar-insert-project-hierarchy (project indent &optional rescan)
+ "Insert hierarchy of project. Rescan directories if RESCAN is non-nil,
+otherwise use cached data."
+ (when (or rescan (and (not (assoc project vhdl-file-alist))
+ (not (vhdl-load-cache project))))
+ (vhdl-scan-project-contents project))
+ ;; insert design hierarchy
+ (vhdl-speedbar-insert-hierarchy
+ (aget vhdl-entity-alist project t)
+ (aget vhdl-config-alist project t)
+ (aget vhdl-package-alist project t)
+ (car (aget vhdl-ent-inst-alist project t)) indent)
+ (insert (int-to-string indent) ":\n")
+ (put-text-property (- (point) 3) (1- (point)) 'invisible t)
+ (put-text-property (1- (point)) (point) 'invisible nil)
+ ;; expand design units
+ (vhdl-speedbar-expand-units project))
+
+(defun vhdl-speedbar-insert-dir-hierarchy (directory depth &optional rescan)
+ "Insert hierarchy of DIRECTORY. Rescan directory if RESCAN is non-nil,
+otherwise use cached data."
+ (when (or rescan (and (not (assoc directory vhdl-file-alist))
+ (not (vhdl-load-cache directory))))
+ (vhdl-scan-directory-contents directory))
+ ;; insert design hierarchy
+ (vhdl-speedbar-insert-hierarchy
+ (aget vhdl-entity-alist directory t)
+ (aget vhdl-config-alist directory t)
+ (aget vhdl-package-alist directory t)
+ (car (aget vhdl-ent-inst-alist directory t)) depth)
+ ;; expand design units
+ (vhdl-speedbar-expand-units directory)
+ (aput 'vhdl-directory-alist directory (list (list directory))))
+
+(defun vhdl-speedbar-insert-hierarchy (ent-alist conf-alist pack-alist
+ ent-inst-list depth)
+ "Insert hierarchy of ENT-ALIST, CONF-ALIST, and PACK-ALIST."
+ (if (not (or ent-alist conf-alist pack-alist))
+ (vhdl-speedbar-make-title-line "No VHDL design units!" depth)
+ (let (ent-entry conf-entry pack-entry)
+ ;; insert entities
+ (when ent-alist (vhdl-speedbar-make-title-line "Entities:" depth))
+ (while ent-alist
+ (setq ent-entry (car ent-alist))
+ (speedbar-make-tag-line
+ 'bracket ?+ 'vhdl-speedbar-expand-entity (nth 0 ent-entry)
+ (nth 1 ent-entry) 'vhdl-speedbar-find-file
+ (cons (nth 2 ent-entry) (nth 3 ent-entry))
+ 'vhdl-speedbar-entity-face depth)
+ (unless (nth 2 ent-entry)
+ (end-of-line 0) (insert "!") (forward-char 1))
+ (unless (member (nth 0 ent-entry) ent-inst-list)
+ (end-of-line 0) (insert " (top)") (forward-char 1))
+ (setq ent-alist (cdr ent-alist)))
+ ;; insert configurations
+ (when conf-alist (vhdl-speedbar-make-title-line "Configurations:" depth))
+ (while conf-alist
+ (setq conf-entry (car conf-alist))
+ (speedbar-make-tag-line
+ 'bracket ?+ 'vhdl-speedbar-expand-config (nth 0 conf-entry)
+ (nth 1 conf-entry) 'vhdl-speedbar-find-file
+ (cons (nth 2 conf-entry) (nth 3 conf-entry))
+ 'vhdl-speedbar-configuration-face depth)
+ (setq conf-alist (cdr conf-alist)))
+ ;; insert packages
+ (when pack-alist (vhdl-speedbar-make-title-line "Packages:" depth))
+ (while pack-alist
+ (setq pack-entry (car pack-alist))
+ (vhdl-speedbar-make-pack-line
+ (nth 0 pack-entry) (nth 1 pack-entry)
+ (cons (nth 2 pack-entry) (nth 3 pack-entry))
+ (cons (nth 7 pack-entry) (nth 8 pack-entry))
+ depth)
+ (setq pack-alist (cdr pack-alist))))))
+
+(defun vhdl-speedbar-rescan-hierarchy ()
+ "Rescan hierarchy for the directory or project under the cursor."
+ (interactive)
+ (let (key path)
+ (cond
+ ;; current project
+ (vhdl-speedbar-show-projects
+ (setq key (vhdl-speedbar-line-project))
+ (vhdl-scan-project-contents key))
+ ;; top-level directory
+ ((save-excursion (beginning-of-line) (looking-at "[^0-9]"))
+ (re-search-forward "[0-9]+:" nil t)
+ (vhdl-scan-directory-contents
+ (abbreviate-file-name (speedbar-line-path))))
+ ;; current directory
+ (t (setq path (speedbar-line-path))
+ (string-match "^\\(.+[/\\]\\)" path)
+ (vhdl-scan-directory-contents
+ (abbreviate-file-name (match-string 1 path)))))
+ (vhdl-speedbar-refresh key)))
+
+(defun vhdl-speedbar-expand-dirs (directory)
+ "Expand subdirectories in DIRECTORY according to
+ `speedbar-shown-directories'."
+ ;; (nicked from `speedbar-default-directory-list')
+ (let ((sf (cdr (reverse speedbar-shown-directories)))
+ (vhdl-speedbar-update-current-unit nil))
+ (setq speedbar-shown-directories
+ (list (expand-file-name default-directory)))
+ (while sf
+ (when (speedbar-goto-this-file (car sf))
+ (beginning-of-line)
+ (when (looking-at "[0-9]+:\\s-*<")
+ (goto-char (match-end 0))
+ (speedbar-do-function-pointer)))
+ (setq sf (cdr sf))))
+ (vhdl-speedbar-update-current-unit nil t))
+
+(defun vhdl-speedbar-expand-units (key)
+ "Expand design units in directory/project KEY according to
+`vhdl-speedbar-shown-unit-alist'."
+ (let ((unit-alist (aget vhdl-speedbar-shown-unit-alist key t))
+ (vhdl-speedbar-update-current-unit nil)
+ vhdl-updated-project-list)
+ (adelete 'vhdl-speedbar-shown-unit-alist key)
+ (vhdl-prepare-search-1
+ (while unit-alist ; expand units
+ (vhdl-speedbar-goto-this-unit key (caar unit-alist))
+ (beginning-of-line)
+ (let ((arch-alist (nth 1 (car unit-alist)))
+ position)
+ (when (looking-at "^[0-9]+:\\s-*\\[")
+ (goto-char (match-end 0))
+ (setq position (point))
+ (speedbar-do-function-pointer)
+ (select-frame speedbar-frame)
+ (while arch-alist ; expand architectures
+ (goto-char position)
+ (when (re-search-forward
+ (concat "^[0-9]+:\\s-*\\(\\[\\|{.}\\s-+"
+ (car arch-alist) "\\>\\)") nil t)
+ (beginning-of-line)
+ (when (looking-at "^[0-9]+:\\s-*{")
+ (goto-char (match-end 0))
+ (speedbar-do-function-pointer)
+ (select-frame speedbar-frame)))
+ (setq arch-alist (cdr arch-alist))))
+ (setq unit-alist (cdr unit-alist))))))
+ (vhdl-speedbar-update-current-unit nil t))
+
+(defun vhdl-speedbar-contract-level ()
+ "Contract current level in current directory/project."
+ (interactive)
+ (when (or (save-excursion
+ (beginning-of-line) (looking-at "^[0-9]:\\s-*[[{<]-"))
+ (and (save-excursion
+ (beginning-of-line) (looking-at "^\\([0-9]+\\):"))
+ (re-search-backward
+ (format "^[0-%d]:\\s-*[[{<]-"
+ (max (1- (string-to-int (match-string 1))) 0)) nil t)))
+ (goto-char (match-end 0))
+ (speedbar-do-function-pointer)
+ (speedbar-center-buffer-smartly)))
+
+(defun vhdl-speedbar-contract-all ()
+ "Contract all expanded design units in current directory/project."
+ (interactive)
+ (if (and vhdl-speedbar-show-projects
+ (save-excursion (beginning-of-line) (looking-at "^0:")))
+ (progn (setq vhdl-speedbar-shown-project-list nil)
+ (vhdl-speedbar-refresh))
+ (let ((key (vhdl-speedbar-line-key)))
+ (adelete 'vhdl-speedbar-shown-unit-alist key)
+ (vhdl-speedbar-refresh (and vhdl-speedbar-show-projects key))
+ (when (memq 'display vhdl-speedbar-save-cache)
+ (add-to-list 'vhdl-updated-project-list key)))))
+
+(defun vhdl-speedbar-expand-all ()
+ "Expand all design units in current directory/project."
+ (interactive)
+ (let* ((key (vhdl-speedbar-line-key))
+ (ent-alist (aget vhdl-entity-alist key t))
+ (conf-alist (aget vhdl-config-alist key t))
+ (pack-alist (aget vhdl-package-alist key t))
+ arch-alist unit-alist subunit-alist)
+ (add-to-list 'vhdl-speedbar-shown-project-list key)
+ (while ent-alist
+ (setq arch-alist (nth 4 (car ent-alist)))
+ (setq subunit-alist nil)
+ (while arch-alist
+ (setq subunit-alist (cons (caar arch-alist) subunit-alist))
+ (setq arch-alist (cdr arch-alist)))
+ (setq unit-alist (cons (list (caar ent-alist) subunit-alist) unit-alist))
+ (setq ent-alist (cdr ent-alist)))
+ (while conf-alist
+ (setq unit-alist (cons (list (caar conf-alist)) unit-alist))
+ (setq conf-alist (cdr conf-alist)))
+ (while pack-alist
+ (setq unit-alist (cons (list (caar pack-alist)) unit-alist))
+ (setq pack-alist (cdr pack-alist)))
+ (aput 'vhdl-speedbar-shown-unit-alist key unit-alist)
+ (vhdl-speedbar-refresh)
+ (when (memq 'display vhdl-speedbar-save-cache)
+ (add-to-list 'vhdl-updated-project-list key))))
+
+(defun vhdl-speedbar-expand-project (text token indent)
+ "Expand/contract the project under the cursor."
+ (cond
+ ((string-match "+" text) ; expand project
+ (speedbar-change-expand-button-char ?-)
+ (unless (member token vhdl-speedbar-shown-project-list)
+ (setq vhdl-speedbar-shown-project-list
+ (cons token vhdl-speedbar-shown-project-list)))
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ (vhdl-speedbar-insert-project-hierarchy token (1+ indent)
+ speedbar-power-click))))
+ ((string-match "-" text) ; contract project
+ (speedbar-change-expand-button-char ?+)
+ (setq vhdl-speedbar-shown-project-list
+ (delete token vhdl-speedbar-shown-project-list))
+ (speedbar-delete-subblock indent))
+ (t (error "Nothing to display")))
+ (when (equal (selected-frame) speedbar-frame)
+ (speedbar-center-buffer-smartly)))
+
+(defun vhdl-speedbar-expand-entity (text token indent)
+ "Expand/contract the entity under the cursor."
+ (cond
+ ((string-match "+" text) ; expand entity
+ (let* ((key (vhdl-speedbar-line-key indent))
+ (ent-alist (aget vhdl-entity-alist key t))
+ (ent-entry (aget ent-alist token t))
+ (arch-alist (nth 3 ent-entry))
+ (inst-alist (vhdl-get-instantiations token indent))
+ (subpack-alist (nth 4 ent-entry))
+ arch-entry inst-entry)
+ (if (not (or arch-alist inst-alist subpack-alist))
+ (speedbar-change-expand-button-char ??)
+ (speedbar-change-expand-button-char ?-)
+ ;; add entity to `vhdl-speedbar-shown-unit-alist'
+ (let* ((unit-alist (aget vhdl-speedbar-shown-unit-alist key t)))
+ (aput 'unit-alist token nil)
+ (aput 'vhdl-speedbar-shown-unit-alist key unit-alist))
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ ;; insert architectures
+ (when arch-alist
+ (vhdl-speedbar-make-title-line "Architectures:" (1+ indent)))
+ (while arch-alist
+ (setq arch-entry (car arch-alist))
+ (speedbar-make-tag-line
+ 'curly ?+ 'vhdl-speedbar-expand-architecture
+ (cons token (nth 0 arch-entry))
+ (nth 1 arch-entry) 'vhdl-speedbar-find-file
+ (cons (nth 2 arch-entry) (nth 3 arch-entry))
+ 'vhdl-speedbar-architecture-face (1+ indent))
+ (setq arch-alist (cdr arch-alist)))
+ ;; insert instantiations
+ (when inst-alist
+ (vhdl-speedbar-make-title-line "Instantiated as:" (1+ indent)))
+ (while inst-alist
+ (setq inst-entry (car inst-alist))
+ (vhdl-speedbar-make-inst-line
+ (nth 0 inst-entry) (nth 1 inst-entry) (nth 2 inst-entry)
+ (nth 3 inst-entry) (nth 4 inst-entry) (nth 5 inst-entry)
+ nil nil nil (1+ indent) 0 " in ")
+ (setq inst-alist (cdr inst-alist)))
+ ;; insert required packages
+ (vhdl-speedbar-insert-subpackages
+ subpack-alist (1+ indent) indent)))
+ (when (memq 'display vhdl-speedbar-save-cache)
+ (add-to-list 'vhdl-updated-project-list key))
+ (vhdl-speedbar-update-current-unit t t))))
+ ((string-match "-" text) ; contract entity
+ (speedbar-change-expand-button-char ?+)
+ ;; remove entity from `vhdl-speedbar-shown-unit-alist'
+ (let* ((key (vhdl-speedbar-line-key indent))
+ (unit-alist (aget vhdl-speedbar-shown-unit-alist key t)))
+ (adelete 'unit-alist token)
+ (if unit-alist
+ (aput 'vhdl-speedbar-shown-unit-alist key unit-alist)
+ (adelete 'vhdl-speedbar-shown-unit-alist key))
+ (speedbar-delete-subblock indent)
+ (when (memq 'display vhdl-speedbar-save-cache)
+ (add-to-list 'vhdl-updated-project-list key))))
+ (t (error "Nothing to display")))
+ (when (equal (selected-frame) speedbar-frame)
+ (speedbar-center-buffer-smartly)))
+
+(defun vhdl-speedbar-expand-architecture (text token indent)
+ "Expand/contract the architecture under the cursor."
+ (cond
+ ((string-match "+" text) ; expand architecture
+ (let* ((key (vhdl-speedbar-line-key (1- indent)))
+ (ent-alist (aget vhdl-entity-alist key t))
+ (conf-alist (aget vhdl-config-alist key t))
+ (hier-alist (vhdl-get-hierarchy
+ ent-alist conf-alist (car token) (cdr token) nil nil
+ 0 (1- indent)))
+ (ent-entry (aget ent-alist (car token) t))
+ (arch-entry (aget (nth 3 ent-entry) (cdr token) t))
+ (subpack-alist (nth 4 arch-entry))
+ entry)
+ (if (not (or hier-alist subpack-alist))
+ (speedbar-change-expand-button-char ??)
+ (speedbar-change-expand-button-char ?-)
+ ;; add architecture to `vhdl-speedbar-shown-unit-alist'
+ (let* ((unit-alist (aget vhdl-speedbar-shown-unit-alist key t))
+ (arch-alist (nth 0 (aget unit-alist (car token) t))))
+ (aput 'unit-alist (car token) (list (cons (cdr token) arch-alist)))
+ (aput 'vhdl-speedbar-shown-unit-alist key unit-alist))
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ ;; insert instance hierarchy
+ (when hier-alist
+ (vhdl-speedbar-make-title-line "Subcomponent hierarchy:"
+ (1+ indent)))
+ (while hier-alist
+ (setq entry (car hier-alist))
+ (when (or (= vhdl-speedbar-hierarchy-depth 0)
+ (< (nth 9 entry) vhdl-speedbar-hierarchy-depth))
+ (vhdl-speedbar-make-inst-line
+ (nth 0 entry) (nth 1 entry) (nth 2 entry) (nth 3 entry)
+ (nth 4 entry) (nth 5 entry) (nth 6 entry) (nth 7 entry)
+ (nth 8 entry) (1+ indent) (1+ (nth 9 entry)) ": "))
+ (setq hier-alist (cdr hier-alist)))
+ ;; insert required packages
+ (vhdl-speedbar-insert-subpackages
+ subpack-alist (1+ indent) (1- indent))))
+ (when (memq 'display vhdl-speedbar-save-cache)
+ (add-to-list 'vhdl-updated-project-list key))
+ (vhdl-speedbar-update-current-unit t t))))
+ ((string-match "-" text) ; contract architecture
+ (speedbar-change-expand-button-char ?+)
+ ;; remove architecture from `vhdl-speedbar-shown-unit-alist'
+ (let* ((key (vhdl-speedbar-line-key (1- indent)))
+ (unit-alist (aget vhdl-speedbar-shown-unit-alist key t))
+ (arch-alist (nth 0 (aget unit-alist (car token) t))))
+ (aput 'unit-alist (car token) (list (delete (cdr token) arch-alist)))
+ (aput 'vhdl-speedbar-shown-unit-alist key unit-alist)
+ (speedbar-delete-subblock indent)
+ (when (memq 'display vhdl-speedbar-save-cache)
+ (add-to-list 'vhdl-updated-project-list key))))
+ (t (error "Nothing to display")))
+ (when (equal (selected-frame) speedbar-frame)
+ (speedbar-center-buffer-smartly)))
+
+(defun vhdl-speedbar-expand-config (text token indent)
+ "Expand/contract the configuration under the cursor."
+ (cond
+ ((string-match "+" text) ; expand configuration
+ (let* ((key (vhdl-speedbar-line-key indent))
+ (conf-alist (aget vhdl-config-alist key t))
+ (conf-entry (aget conf-alist token))
+ (ent-alist (aget vhdl-entity-alist key t))
+ (hier-alist (vhdl-get-hierarchy
+ ent-alist conf-alist (nth 3 conf-entry)
+ (nth 4 conf-entry) token (nth 5 conf-entry)
+ 0 indent t))
+ (subpack-alist (nth 6 conf-entry))
+ entry)
+ (if (not (or hier-alist subpack-alist))
+ (speedbar-change-expand-button-char ??)
+ (speedbar-change-expand-button-char ?-)
+ ;; add configuration to `vhdl-speedbar-shown-unit-alist'
+ (let* ((unit-alist (aget vhdl-speedbar-shown-unit-alist key t)))
+ (aput 'unit-alist token nil)
+ (aput 'vhdl-speedbar-shown-unit-alist key unit-alist))
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ ;; insert instance hierarchy
+ (when hier-alist
+ (vhdl-speedbar-make-title-line "Design hierarchy:" (1+ indent)))
+ (while hier-alist
+ (setq entry (car hier-alist))
+ (when (or (= vhdl-speedbar-hierarchy-depth 0)
+ (<= (nth 9 entry) vhdl-speedbar-hierarchy-depth))
+ (vhdl-speedbar-make-inst-line
+ (nth 0 entry) (nth 1 entry) (nth 2 entry) (nth 3 entry)
+ (nth 4 entry) (nth 5 entry) (nth 6 entry) (nth 7 entry)
+ (nth 8 entry) (1+ indent) (nth 9 entry) ": "))
+ (setq hier-alist (cdr hier-alist)))
+ ;; insert required packages
+ (vhdl-speedbar-insert-subpackages
+ subpack-alist (1+ indent) indent)))
+ (when (memq 'display vhdl-speedbar-save-cache)
+ (add-to-list 'vhdl-updated-project-list key))
+ (vhdl-speedbar-update-current-unit t t))))
+ ((string-match "-" text) ; contract configuration
+ (speedbar-change-expand-button-char ?+)
+ ;; remove configuration from `vhdl-speedbar-shown-unit-alist'
+ (let* ((key (vhdl-speedbar-line-key indent))
+ (unit-alist (aget vhdl-speedbar-shown-unit-alist key t)))
+ (adelete 'unit-alist token)
+ (if unit-alist
+ (aput 'vhdl-speedbar-shown-unit-alist key unit-alist)
+ (adelete 'vhdl-speedbar-shown-unit-alist key))
+ (speedbar-delete-subblock indent)
+ (when (memq 'display vhdl-speedbar-save-cache)
+ (add-to-list 'vhdl-updated-project-list key))))
+ (t (error "Nothing to display")))
+ (when (equal (selected-frame) speedbar-frame)
+ (speedbar-center-buffer-smartly)))
+
+(defun vhdl-speedbar-expand-package (text token indent)
+ "Expand/contract the package under the cursor."
+ (cond
+ ((string-match "+" text) ; expand package
+ (let* ((key (vhdl-speedbar-line-key indent))
+ (pack-alist (aget vhdl-package-alist key t))
+ (pack-entry (aget pack-alist token t))
+ (comp-alist (nth 3 pack-entry))
+ (func-alist (nth 4 pack-entry))
+ (func-body-alist (nth 8 pack-entry))
+ (subpack-alist (append (nth 5 pack-entry) (nth 9 pack-entry)))
+ comp-entry func-entry func-body-entry)
+ (if (not (or comp-alist func-alist subpack-alist))
+ (speedbar-change-expand-button-char ??)
+ (speedbar-change-expand-button-char ?-)
+ ;; add package to `vhdl-speedbar-shown-unit-alist'
+ (let* ((unit-alist (aget vhdl-speedbar-shown-unit-alist key t)))
+ (aput 'unit-alist token nil)
+ (aput 'vhdl-speedbar-shown-unit-alist key unit-alist))
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ ;; insert components
+ (when comp-alist
+ (vhdl-speedbar-make-title-line "Components:" (1+ indent)))
+ (while comp-alist
+ (setq comp-entry (car comp-alist))
+ (speedbar-make-tag-line
+ nil nil nil
+ (cons token (nth 0 comp-entry))
+ (nth 1 comp-entry) 'vhdl-speedbar-find-file
+ (cons (nth 2 comp-entry) (nth 3 comp-entry))
+ 'vhdl-speedbar-entity-face (1+ indent))
+ (setq comp-alist (cdr comp-alist)))
+ ;; insert subprograms
+ (when func-alist
+ (vhdl-speedbar-make-title-line "Subprograms:" (1+ indent)))
+ (while func-alist
+ (setq func-entry (car func-alist)
+ func-body-entry (aget func-body-alist (car func-entry) t))
+ (when (nth 2 func-entry)
+ (vhdl-speedbar-make-subprogram-line
+ (nth 1 func-entry)
+ (cons (nth 2 func-entry) (nth 3 func-entry))
+ (cons (nth 1 func-body-entry) (nth 2 func-body-entry))
+ (1+ indent)))
+ (setq func-alist (cdr func-alist)))
+ ;; insert required packages
+ (vhdl-speedbar-insert-subpackages
+ subpack-alist (1+ indent) indent)))
+ (when (memq 'display vhdl-speedbar-save-cache)
+ (add-to-list 'vhdl-updated-project-list key))
+ (vhdl-speedbar-update-current-unit t t))))
+ ((string-match "-" text) ; contract package
+ (speedbar-change-expand-button-char ?+)
+ ;; remove package from `vhdl-speedbar-shown-unit-alist'
+ (let* ((key (vhdl-speedbar-line-key indent))
+ (unit-alist (aget vhdl-speedbar-shown-unit-alist key t)))
+ (adelete 'unit-alist token)
+ (if unit-alist
+ (aput 'vhdl-speedbar-shown-unit-alist key unit-alist)
+ (adelete 'vhdl-speedbar-shown-unit-alist key))
+ (speedbar-delete-subblock indent)
+ (when (memq 'display vhdl-speedbar-save-cache)
+ (add-to-list 'vhdl-updated-project-list key))))
+ (t (error "Nothing to display")))
+ (when (equal (selected-frame) speedbar-frame)
+ (speedbar-center-buffer-smartly)))
+
+(defun vhdl-speedbar-insert-subpackages (subpack-alist indent dir-indent)
+ "Insert required packages."
+ (let* ((pack-alist (aget vhdl-package-alist
+ (vhdl-speedbar-line-key dir-indent) t))
+ pack-key lib-name pack-entry)
+ (when subpack-alist
+ (vhdl-speedbar-make-title-line "Packages Used:" indent))
+ (while subpack-alist
+ (setq pack-key (cdar subpack-alist)
+ lib-name (caar subpack-alist))
+ (setq pack-entry (aget pack-alist pack-key t))
+ (vhdl-speedbar-make-subpack-line
+ (or (nth 0 pack-entry) pack-key) lib-name
+ (cons (nth 1 pack-entry) (nth 2 pack-entry)) indent)
+ (setq subpack-alist (cdr subpack-alist)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Display help functions
+
+(defvar vhdl-speedbar-update-current-unit t
+ "Non-nil means to run `vhdl-speedbar-update-current-unit'.")
+
+(defun vhdl-speedbar-update-current-project ()
+ "Highlight project that is currently active."
+ (when (and vhdl-speedbar-show-projects
+ (not (equal vhdl-speedbar-last-selected-project vhdl-project))
+ (and (boundp 'speedbar-frame)
+ (frame-live-p speedbar-frame)))
+ (let ((last-frame (selected-frame))
+ (project-alist vhdl-project-alist)
+ pos)
+ (select-frame speedbar-frame)
+ (speedbar-with-writable
+ (save-excursion
+ (while project-alist
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "<.> \\(" (caar project-alist) "\\)$") nil t)
+ (put-text-property (match-beginning 1) (match-end 1) 'face
+ (if (equal (caar project-alist) vhdl-project)
+ 'speedbar-selected-face
+ 'speedbar-directory-face))
+ (when (equal (caar project-alist) vhdl-project)
+ (setq pos (1- (match-beginning 1)))))
+ (setq project-alist (cdr project-alist))))
+ (when pos (goto-char pos)))
+ (select-frame last-frame)
+ (setq vhdl-speedbar-last-selected-project vhdl-project)))
+ t)
+
+(defun vhdl-speedbar-update-current-unit (&optional no-position always)
+ "Highlight all design units that are contained in the current file.
+NO-POSITION non-nil means do not re-position cursor."
+ (let ((last-frame (selected-frame))
+ (project-list vhdl-speedbar-shown-project-list)
+ file-alist pos file-name)
+ ;; get current file name
+ (if (fboundp 'speedbar-select-attached-frame)
+ (speedbar-select-attached-frame)
+ (select-frame speedbar-attached-frame))
+ (setq file-name (abbreviate-file-name (or (buffer-file-name) "")))
+ (when (and vhdl-speedbar-update-current-unit
+ (or always (not (equal file-name speedbar-last-selected-file))))
+ (if vhdl-speedbar-show-projects
+ (while project-list
+ (setq file-alist (append file-alist (aget vhdl-file-alist
+ (car project-list) t)))
+ (setq project-list (cdr project-list)))
+ (setq file-alist (aget vhdl-file-alist
+ (abbreviate-file-name default-directory) t)))
+ (select-frame speedbar-frame)
+ (set-buffer speedbar-buffer)
+ (speedbar-with-writable
+ (vhdl-prepare-search-1
+ (save-excursion
+ ;; unhighlight last units
+ (let* ((file-entry (aget file-alist speedbar-last-selected-file t)))
+ (vhdl-speedbar-update-units
+ "\\[.\\] " (nth 0 file-entry)
+ speedbar-last-selected-file 'vhdl-speedbar-entity-face)
+ (vhdl-speedbar-update-units
+ "{.} " (nth 1 file-entry)
+ speedbar-last-selected-file 'vhdl-speedbar-architecture-face)
+ (vhdl-speedbar-update-units
+ "\\[.\\] " (nth 3 file-entry)
+ speedbar-last-selected-file 'vhdl-speedbar-configuration-face)
+ (vhdl-speedbar-update-units
+ "[]>] " (nth 4 file-entry)
+ speedbar-last-selected-file 'vhdl-speedbar-package-face)
+ (vhdl-speedbar-update-units
+ "\\[.\\].+(" '("body")
+ speedbar-last-selected-file 'vhdl-speedbar-package-face)
+ (vhdl-speedbar-update-units
+ "> " (nth 6 file-entry)
+ speedbar-last-selected-file 'vhdl-speedbar-instantiation-face))
+ ;; highlight current units
+ (let* ((file-entry (aget file-alist file-name t)))
+ (setq
+ pos (vhdl-speedbar-update-units
+ "\\[.\\] " (nth 0 file-entry)
+ file-name 'vhdl-speedbar-entity-selected-face pos)
+ pos (vhdl-speedbar-update-units
+ "{.} " (nth 1 file-entry)
+ file-name 'vhdl-speedbar-architecture-selected-face pos)
+ pos (vhdl-speedbar-update-units
+ "\\[.\\] " (nth 3 file-entry)
+ file-name 'vhdl-speedbar-configuration-selected-face pos)
+ pos (vhdl-speedbar-update-units
+ "[]>] " (nth 4 file-entry)
+ file-name 'vhdl-speedbar-package-selected-face pos)
+ pos (vhdl-speedbar-update-units
+ "\\[.\\].+(" '("body")
+ file-name 'vhdl-speedbar-package-selected-face pos)
+ pos (vhdl-speedbar-update-units
+ "> " (nth 6 file-entry)
+ file-name 'vhdl-speedbar-instantiation-selected-face pos))))))
+ ;; move speedbar so the first highlighted unit is visible
+ (when (and pos (not no-position))
+ (goto-char pos)
+ (speedbar-center-buffer-smartly)
+ (speedbar-position-cursor-on-line))
+ (setq speedbar-last-selected-file file-name))
+ (select-frame last-frame)
+ t))
+
+(defun vhdl-speedbar-update-units (text unit-list file-name face
+ &optional pos)
+ "Help function to highlight design units."
+ (while unit-list
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat text "\\(" (car unit-list) "\\)\\>") nil t)
+ (when (equal file-name (car (get-text-property
+ (match-beginning 1) 'speedbar-token)))
+ (setq pos (or pos (point-marker)))
+ (put-text-property (match-beginning 1) (match-end 1) 'face face)))
+ (setq unit-list (cdr unit-list)))
+ pos)
+
+(defun vhdl-speedbar-make-inst-line (inst-name inst-file-marker
+ ent-name ent-file-marker
+ arch-name arch-file-marker
+ conf-name conf-file-marker
+ lib-name depth offset delimiter)
+ "Insert instantiation entry."
+ (let ((start (point))
+ visible-start)
+ (insert (int-to-string depth) ":")
+ (put-text-property start (point) 'invisible t)
+ (setq visible-start (point))
+ (insert-char ? (* depth speedbar-indentation-width))
+ (while (> offset 0)
+ (insert "|")
+ (insert-char (if (= offset 1) ?- ? ) (1- speedbar-indentation-width))
+ (setq offset (1- offset)))
+ (put-text-property visible-start (point) 'invisible nil)
+ (setq start (point))
+ (insert ">")
+ (speedbar-make-button start (point) nil nil nil)
+ (setq visible-start (point))
+ (insert " ")
+ (setq start (point))
+ (if (not inst-name)
+ (insert "(top)")
+ (insert inst-name)
+ (speedbar-make-button
+ start (point) 'vhdl-speedbar-instantiation-face 'speedbar-highlight-face
+ 'vhdl-speedbar-find-file inst-file-marker))
+ (insert delimiter)
+ (when ent-name
+ (setq start (point))
+ (insert ent-name)
+ (speedbar-make-button
+ start (point) 'vhdl-speedbar-entity-face 'speedbar-highlight-face
+ 'vhdl-speedbar-find-file ent-file-marker)
+ (when arch-name
+ (insert " (")
+ (setq start (point))
+ (insert arch-name)
+ (speedbar-make-button
+ start (point) 'vhdl-speedbar-architecture-face 'speedbar-highlight-face
+ 'vhdl-speedbar-find-file arch-file-marker)
+ (insert ")"))
+ (when conf-name
+ (insert " (")
+ (setq start (point))
+ (insert conf-name)
+ (speedbar-make-button
+ start (point) 'vhdl-speedbar-configuration-face 'speedbar-highlight-face
+ 'vhdl-speedbar-find-file conf-file-marker)
+ (insert ")")))
+ (when (and lib-name (not (equal lib-name (downcase (vhdl-work-library)))))
+ (setq start (point))
+ (insert " (" lib-name ")")
+ (put-text-property (+ 2 start) (1- (point)) 'face
+ 'vhdl-speedbar-library-face))
+ (insert-char ?\n 1)
+ (put-text-property visible-start (point) 'invisible nil)))
+
+(defun vhdl-speedbar-make-pack-line (pack-key pack-name pack-file-marker
+ body-file-marker depth)
+ "Insert package entry."
+ (let ((start (point))
+ visible-start)
+ (insert (int-to-string depth) ":")
+ (put-text-property start (point) 'invisible t)
+ (setq visible-start (point))
+ (insert-char ? (* depth speedbar-indentation-width))
+ (put-text-property visible-start (point) 'invisible nil)
+ (setq start (point))
+ (insert "[+]")
+ (speedbar-make-button
+ start (point) 'speedbar-button-face 'speedbar-highlight-face
+ 'vhdl-speedbar-expand-package pack-key)
+ (setq visible-start (point))
+ (insert-char ? 1 nil)
+ (setq start (point))
+ (insert pack-name)
+ (speedbar-make-button
+ start (point) 'vhdl-speedbar-package-face 'speedbar-highlight-face
+ 'vhdl-speedbar-find-file pack-file-marker)
+ (unless (car pack-file-marker)
+ (insert "!"))
+ (when (car body-file-marker)
+ (insert " (")
+ (setq start (point))
+ (insert "body")
+ (speedbar-make-button
+ start (point) 'vhdl-speedbar-package-face 'speedbar-highlight-face
+ 'vhdl-speedbar-find-file body-file-marker)
+ (insert ")"))
+ (insert-char ?\n 1)
+ (put-text-property visible-start (point) 'invisible nil)))
+
+(defun vhdl-speedbar-make-subpack-line (pack-name lib-name pack-file-marker
+ depth)
+ "Insert used package entry."
+ (let ((start (point))
+ visible-start)
+ (insert (int-to-string depth) ":")
+ (put-text-property start (point) 'invisible t)
+ (setq visible-start (point))
+ (insert-char ? (* depth speedbar-indentation-width))
+ (put-text-property visible-start (point) 'invisible nil)
+ (setq start (point))
+ (insert ">")
+ (speedbar-make-button start (point) nil nil nil)
+ (setq visible-start (point))
+ (insert " ")
+ (setq start (point))
+ (insert pack-name)
+ (speedbar-make-button
+ start (point) 'vhdl-speedbar-package-face 'speedbar-highlight-face
+ 'vhdl-speedbar-find-file pack-file-marker)
+ (setq start (point))
+ (insert " (" lib-name ")")
+ (put-text-property (+ 2 start) (1- (point)) 'face
+ 'vhdl-speedbar-library-face)
+ (insert-char ?\n 1)
+ (put-text-property visible-start (point) 'invisible nil)))
+
+(defun vhdl-speedbar-make-subprogram-line (func-name func-file-marker
+ func-body-file-marker
+ depth)
+ "Insert subprogram entry."
+ (let ((start (point))
+ visible-start)
+ (insert (int-to-string depth) ":")
+ (put-text-property start (point) 'invisible t)
+ (setq visible-start (point))
+ (insert-char ? (* depth speedbar-indentation-width))
+ (put-text-property visible-start (point) 'invisible nil)
+ (setq start (point))
+ (insert ">")
+ (speedbar-make-button start (point) nil nil nil)
+ (setq visible-start (point))
+ (insert " ")
+ (setq start (point))
+ (insert func-name)
+ (speedbar-make-button
+ start (point) 'vhdl-speedbar-subprogram-face 'speedbar-highlight-face
+ 'vhdl-speedbar-find-file func-file-marker)
+ (when (car func-body-file-marker)
+ (insert " (")
+ (setq start (point))
+ (insert "body")
+ (speedbar-make-button
+ start (point) 'vhdl-speedbar-subprogram-face 'speedbar-highlight-face
+ 'vhdl-speedbar-find-file func-body-file-marker)
+ (insert ")"))
+ (insert-char ?\n 1)
+ (put-text-property visible-start (point) 'invisible nil)))
+
+(defun vhdl-speedbar-make-title-line (text &optional depth)
+ "Insert design unit title entry."
+ (let ((start (point))
+ visible-start)
+ (when depth
+ (insert (int-to-string depth) ":")
+ (put-text-property start (point) 'invisible t))
+ (setq visible-start (point))
+ (insert-char ? (* (or depth 0) speedbar-indentation-width))
+ (setq start (point))
+ (insert text)
+ (speedbar-make-button start (point) nil nil nil nil)
+ (insert-char ?\n 1)
+ (put-text-property visible-start (point) 'invisible nil)))
+
+(defun vhdl-speedbar-insert-dirs (files level)
+ "Insert subdirectories."
+ (let ((dirs (car files)))
+ (while dirs
+ (speedbar-make-tag-line 'angle ?+ 'vhdl-speedbar-dired (car dirs)
+ (car dirs) 'speedbar-dir-follow nil
+ 'speedbar-directory-face level)
+ (setq dirs (cdr dirs)))))
+
+(defun vhdl-speedbar-dired (text token indent)
+ "Speedbar click handler for directory expand button in hierarchy mode."
+ (cond ((string-match "+" text) ; we have to expand this dir
+ (setq speedbar-shown-directories
+ (cons (expand-file-name
+ (concat (speedbar-line-path indent) token "/"))
+ speedbar-shown-directories))
+ (speedbar-change-expand-button-char ?-)
+ (speedbar-reset-scanners)
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ (vhdl-speedbar-insert-dirs
+ (speedbar-file-lists
+ (concat (speedbar-line-path indent) token "/"))
+ (1+ indent))
+ (speedbar-reset-scanners)
+ (vhdl-speedbar-insert-dir-hierarchy
+ (abbreviate-file-name
+ (concat (speedbar-line-path indent) token "/"))
+ (1+ indent) speedbar-power-click)))
+ (vhdl-speedbar-update-current-unit t t))
+ ((string-match "-" text) ; we have to contract this node
+ (speedbar-reset-scanners)
+ (let ((oldl speedbar-shown-directories)
+ (newl nil)
+ (td (expand-file-name
+ (concat (speedbar-line-path indent) token))))
+ (while oldl
+ (if (not (string-match (concat "^" (regexp-quote td)) (car oldl)))
+ (setq newl (cons (car oldl) newl)))
+ (setq oldl (cdr oldl)))
+ (setq speedbar-shown-directories (nreverse newl)))
+ (speedbar-change-expand-button-char ?+)
+ (speedbar-delete-subblock indent))
+ (t (error "Nothing to display")))
+ (when (equal (selected-frame) speedbar-frame)
+ (speedbar-center-buffer-smartly)))
+
+(defun vhdl-speedbar-item-info ()
+ "Derive and display information about this line item."
+ (save-excursion
+ (beginning-of-line)
+ ;; skip invisible number info
+ (when (looking-at "^[0-9]+:") (goto-char (match-end 0)))
+ (cond
+ ;; project/directory entry
+ ((looking-at "\\s-*<[-+?]>\\s-+\\([^\n]+\\)$")
+ (if vhdl-speedbar-show-projects
+ (message "Project \"%s\"" (match-string-no-properties 1))
+ (speedbar-files-item-info)))
+ ;; design unit entry
+ ((looking-at "\\(\\s-*\\([[{][-+?][]}]\\|[| -]*>\\) \\)\"?\\w")
+ (goto-char (match-end 1))
+ (let ((face (get-text-property (point) 'face)))
+ (message
+ "%s \"%s\" in \"%s\""
+ ;; design unit kind
+ (cond ((or (eq face 'vhdl-speedbar-entity-face)
+ (eq face 'vhdl-speedbar-entity-selected-face))
+ (if (equal (match-string 2) ">") "Component" "Entity"))
+ ((or (eq face 'vhdl-speedbar-architecture-face)
+ (eq face 'vhdl-speedbar-architecture-selected-face))
+ "Architecture")
+ ((or (eq face 'vhdl-speedbar-configuration-face)
+ (eq face 'vhdl-speedbar-configuration-selected-face))
+ "Configuration")
+ ((or (eq face 'vhdl-speedbar-package-face)
+ (eq face 'vhdl-speedbar-package-selected-face))
+ "Package")
+ ((or (eq face 'vhdl-speedbar-instantiation-face)
+ (eq face 'vhdl-speedbar-instantiation-selected-face))
+ "Instantiation")
+ ((eq face 'vhdl-speedbar-subprogram-face)
+ "Subprogram")
+ (t ""))
+ ;; design unit name
+ (buffer-substring-no-properties
+ (progn (looking-at "\"?\\(\\(\\w\\|_\\)+\\)\"?") (match-beginning 1))
+ (match-end 1))
+ ;; file name
+ (file-relative-name
+ (or (car (get-text-property (point) 'speedbar-token))
+ "?")
+ (vhdl-default-directory)))))
+ (t (message "")))))
+
+(defun vhdl-speedbar-line-text ()
+ "Calls `speedbar-line-text' and removes text properties."
+ (let ((string (speedbar-line-text)))
+ (set-text-properties 0 (length string) nil string)
+ string))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Help functions